From e72177985e2ce4fa3b1c251e566ff24c6e5920ec Mon Sep 17 00:00:00 2001 From: mikew50 Date: Sun, 1 Oct 2017 17:47:47 -0600 Subject: [PATCH] ORCA/C 2.1.0 source from the Opus ][ CD --- Asm.pas | 1 + CC.pas | 1 + CC.rez | 1 + CC.rez2 | 1 + CCommon.asm | 1 + CCommon.macros | 1 + CCommon.pas | 1 + CGC.asm | 1 + CGC.macros | 1 + CGC.pas | 1 + CGI.Comments | 1 + CGI.Debug | 1 + CGI.pas | 1 + DAG.pas | 1 + DAG2.pas | 1 + Exp.macros | 1 + Expression.asm | 1 + Expression.pas | 1 + Gen.pas | 1 + Header.pas | 1 + Header2.pas | 1 + LICENSE | 11 +++++++++++ MM.asm | 1 + MM.macros | 1 + MM.pas | 1 + Native.asm | 1 + Native.macros | 1 + Native.pas | 1 + Native2.pas | 1 + ObjOut.asm | 1 + ObjOut.macros | 1 + ObjOut.pas | 1 + ObjOut2.asm | 1 + ObjOut2.pas | 1 + Parser.pas | 1 + README.md | 18 ++++++++++++++++++ Scanner.asm | 1 + Scanner.debug | 1 + Scanner.macros | 1 + Scanner.pas | 1 + Symbol.Print | 1 + Symbol.asm | 1 + Symbol.macros | 1 + Symbol.pas | 1 + Table.asm | 1 + Table.macros | 1 + Table.pas | 1 + Tests/Conformance/C11.4.2.1.CC | 1 + Tests/Conformance/C13.1.0.1.CC | 1 + Tests/Conformance/C14.1.0.1.CC | 1 + Tests/Conformance/C14.2.0.1.CC | 1 + Tests/Conformance/C14.3.0.1.CC | 1 + Tests/Conformance/C14.5.0.1.CC | 1 + Tests/Conformance/C14.6.0.1.CC | 1 + Tests/Conformance/C14.7.0.1.CC | 1 + Tests/Conformance/C14.8.0.1.CC | 1 + Tests/Conformance/C14.9.0.1.CC | 1 + Tests/Conformance/C15.1.0.1.CC | 1 + Tests/Conformance/C15.2.0.1.CC | 1 + Tests/Conformance/C15.3.0.1.CC | 1 + Tests/Conformance/C15.5.0.1.CC | 1 + Tests/Conformance/C15.6.0.1.CC | 1 + Tests/Conformance/C15.7.0.1.CC | 1 + Tests/Conformance/C15.7.0.2.CC | 1 + Tests/Conformance/C15.8.0.1.CC | 1 + Tests/Conformance/C15.8.0.2.CC | 1 + Tests/Conformance/C15.9.0.1.CC | 1 + Tests/Conformance/C16.1.0.1.CC | 1 + Tests/Conformance/C16.4.0.1.CC | 1 + Tests/Conformance/C17.10.0.1.CC | 1 + Tests/Conformance/C17.11.0.1.CC | 1 + Tests/Conformance/C17.11.0.10.CC | 1 + Tests/Conformance/C17.11.0.11.CC | 1 + Tests/Conformance/C17.11.0.2.CC | 1 + Tests/Conformance/C17.11.0.3.CC | 1 + Tests/Conformance/C17.11.0.4.CC | 1 + Tests/Conformance/C17.11.0.5.CC | 1 + Tests/Conformance/C17.11.0.6.CC | 1 + Tests/Conformance/C17.11.0.7.CC | 1 + Tests/Conformance/C17.11.0.8.CC | 1 + Tests/Conformance/C17.11.0.9.CC | 1 + Tests/Conformance/C17.13.0.1.CC | 1 + Tests/Conformance/C17.14.0.1.CC | 1 + Tests/Conformance/C17.15.0.1.CC | 1 + Tests/Conformance/C17.16.0.1.CC | 1 + Tests/Conformance/C17.5.0.1.CC | 1 + Tests/Conformance/C17.5.0.2.CC | 1 + Tests/Conformance/C17.6.0.1.CC | 1 + Tests/Conformance/C17.6.0.2.CC | 1 + Tests/Conformance/C17.7.0.1.CC | 1 + Tests/Conformance/C17.7.0.2.CC | 1 + Tests/Conformance/C17.8.0.1.CC | 1 + Tests/Conformance/C17.8.0.10.CC | 1 + Tests/Conformance/C17.8.0.11.CC | 1 + Tests/Conformance/C17.8.0.12.CC | 1 + Tests/Conformance/C17.8.0.13.CC | 1 + Tests/Conformance/C17.8.0.14.CC | 1 + Tests/Conformance/C17.8.0.15.CC | 1 + Tests/Conformance/C17.8.0.16.CC | 1 + Tests/Conformance/C17.8.0.17.CC | 1 + Tests/Conformance/C17.8.0.18.CC | 1 + Tests/Conformance/C17.8.0.19.CC | 1 + Tests/Conformance/C17.8.0.2.CC | 1 + Tests/Conformance/C17.8.0.20.CC | 1 + Tests/Conformance/C17.8.0.21.CC | 1 + Tests/Conformance/C17.8.0.22.CC | 1 + Tests/Conformance/C17.8.0.23.CC | 1 + Tests/Conformance/C17.8.0.24.CC | 1 + Tests/Conformance/C17.8.0.3.CC | 1 + Tests/Conformance/C17.8.0.4.CC | 1 + Tests/Conformance/C17.8.0.5.CC | 1 + Tests/Conformance/C17.8.0.6.CC | 1 + Tests/Conformance/C17.8.0.7.CC | 1 + Tests/Conformance/C17.8.0.8.CC | 1 + Tests/Conformance/C17.8.0.9.CC | 1 + Tests/Conformance/C17.9.0.1.CC | 1 + Tests/Conformance/C18.1.0.1.CC | 1 + Tests/Conformance/C18.3.0.1.CC | 1 + Tests/Conformance/C19.1.0.1.CC | 1 + Tests/Conformance/C19.10.0.1.CC | 1 + Tests/Conformance/C19.2.0.1.CC | 1 + Tests/Conformance/C19.3.0.1.CC | 1 + Tests/Conformance/C19.4.0.1.CC | 1 + Tests/Conformance/C19.6.0.1.CC | 1 + Tests/Conformance/C19.7.0.1.CC | 1 + Tests/Conformance/C19.8.0.1.CC | 1 + Tests/Conformance/C19.9.0.1.CC | 1 + Tests/Conformance/C2.1.0.1.CC | 1 + Tests/Conformance/C2.1.0.2.CC | 1 + Tests/Conformance/C2.1.0.3.CC | 1 + Tests/Conformance/C2.1.0.4.CC | 1 + Tests/Conformance/C2.1.1.1.CC | 1 + Tests/Conformance/C2.1.1.2.CC | 1 + Tests/Conformance/C2.1.2.1.CC | 2 ++ Tests/Conformance/C2.1.2.2.CC | 1 + Tests/Conformance/C2.1.2.3.CC | 1 + Tests/Conformance/C2.2.0.1.CC | 1 + Tests/Conformance/C2.2.0.2.CC | 1 + Tests/Conformance/C2.2.0.3.CC | 1 + Tests/Conformance/C2.2.0.4.CC | 1 + Tests/Conformance/C2.4.0.1.CC | 1 + Tests/Conformance/C2.4.0.2.CC | 1 + Tests/Conformance/C2.5.0.1.CC | 1 + Tests/Conformance/C2.5.0.2.CC | 1 + Tests/Conformance/C2.5.0.3.CC | 1 + Tests/Conformance/C2.5.0.4.CC | 1 + Tests/Conformance/C2.5.0.5.CC | 1 + Tests/Conformance/C2.5.0.6.CC | 1 + Tests/Conformance/C2.5.0.7.CC | 1 + Tests/Conformance/C2.5.0.8.CC | 1 + Tests/Conformance/C2.6.0.1.CC | 1 + Tests/Conformance/C2.6.0.2.CC | 1 + Tests/Conformance/C2.6.0.3.CC | 1 + Tests/Conformance/C2.6.0.4.CC | 1 + Tests/Conformance/C2.6.0.5.CC | 1 + Tests/Conformance/C2.7.1.1.CC | 1 + Tests/Conformance/C2.7.1.2.CC | 1 + Tests/Conformance/C2.7.1.3.CC | 1 + Tests/Conformance/C2.7.1.4.CC | 1 + Tests/Conformance/C2.7.1.5.CC | 1 + Tests/Conformance/C2.7.1.6.CC | 1 + Tests/Conformance/C2.7.1.7.CC | 1 + Tests/Conformance/C2.7.1.8.CC | 1 + Tests/Conformance/C2.7.2.1.CC | 1 + Tests/Conformance/C2.7.2.2.CC | 1 + Tests/Conformance/C2.7.2.3.CC | 1 + Tests/Conformance/C2.7.3.1.CC | 1 + Tests/Conformance/C2.7.3.2.CC | 1 + Tests/Conformance/C2.7.4.1.CC | 1 + Tests/Conformance/C2.7.4.2.CC | 1 + Tests/Conformance/C2.7.4.3.CC | 1 + Tests/Conformance/C2.7.4.4.CC | 1 + Tests/Conformance/C2.7.7.1.CC | 1 + Tests/Conformance/C2.7.7.2.CC | 1 + Tests/Conformance/C20.1.0.1.CC | 1 + Tests/Conformance/C20.5.0.1.CC | 1 + Tests/Conformance/C21.1.0.2.CC | 1 + Tests/Conformance/C21.4.0.1.CC | 1 + Tests/Conformance/C22.5.0.1.CC | 1 + Tests/Conformance/C23.1.0.1.CC | 1 + Tests/Conformance/C23.2.0.1.CC | 1 + Tests/Conformance/C23.3.0.1.CC | 1 + Tests/Conformance/C23.4.0.1.CC | 1 + Tests/Conformance/C23.5.0.1.CC | 1 + Tests/Conformance/C23.6.0.1.CC | 1 + Tests/Conformance/C24.0.1.CC | 1 + Tests/Conformance/C24.0.2.CC | 1 + Tests/Conformance/C25.0.1.CC | 1 + Tests/Conformance/C25.0.10.CC | 1 + Tests/Conformance/C25.0.11.CC | 1 + Tests/Conformance/C25.0.12.CC | 1 + Tests/Conformance/C25.0.13.CC | 1 + Tests/Conformance/C25.0.14.CC | 1 + Tests/Conformance/C25.0.15.CC | 1 + Tests/Conformance/C25.0.16.CC | 1 + Tests/Conformance/C25.0.17.CC | 1 + Tests/Conformance/C25.0.18.CC | 1 + Tests/Conformance/C25.0.19.CC | 1 + Tests/Conformance/C25.0.2.CC | 1 + Tests/Conformance/C25.0.20.CC | 1 + Tests/Conformance/C25.0.21.CC | 1 + Tests/Conformance/C25.0.22.CC | 1 + Tests/Conformance/C25.0.23.CC | 1 + Tests/Conformance/C25.0.24.CC | 1 + Tests/Conformance/C25.0.25.CC | 1 + Tests/Conformance/C25.0.26.CC | 1 + Tests/Conformance/C25.0.3.CC | 1 + Tests/Conformance/C25.0.4.CC | 1 + Tests/Conformance/C25.0.5.CC | 1 + Tests/Conformance/C25.0.6.CC | 1 + Tests/Conformance/C25.0.7.CC | 1 + Tests/Conformance/C25.0.8.CC | 1 + Tests/Conformance/C25.0.9.CC | 1 + Tests/Conformance/C3.3.0.1.CC | 1 + Tests/Conformance/C3.3.1.1.CC | 1 + Tests/Conformance/C3.3.2.1.CC | 1 + Tests/Conformance/C3.3.3.1.CC | 1 + Tests/Conformance/C3.3.4.1.CC | 1 + Tests/Conformance/C3.3.5.1.CC | 1 + Tests/Conformance/C3.3.6.1.CC | 1 + Tests/Conformance/C3.3.8.1.CC | 1 + Tests/Conformance/C3.3.9.1.CC | 1 + Tests/Conformance/C3.5.1.1.CC | 1 + Tests/Conformance/C3.5.1.2.CC | 1 + Tests/Conformance/C3.5.1.3.CC | 1 + Tests/Conformance/C3.5.1.4.CC | 1 + Tests/Conformance/C3.5.1.5.CC | 1 + Tests/Conformance/C3.5.2.1.CC | 1 + Tests/Conformance/C3.5.2.2.CC | 1 + Tests/Conformance/C3.5.2.3.CC | 1 + Tests/Conformance/C3.5.2.4.CC | 1 + Tests/Conformance/C3.5.3.1.CC | 1 + Tests/Conformance/C3.5.4.1.CC | 1 + Tests/Conformance/C3.5.4.2.CC | 1 + Tests/Conformance/C4.2.1.1.CC | 1 + Tests/Conformance/C4.2.2.1.CC | 1 + Tests/Conformance/C4.2.4.1.CC | 1 + Tests/Conformance/C4.2.5.1.CC | 1 + Tests/Conformance/C4.3.0.1.CC | 1 + Tests/Conformance/C4.3.0.2.CC | 1 + Tests/Conformance/C4.4.2.1.CC | 1 + Tests/Conformance/C4.5.2.1.CC | 1 + Tests/Conformance/C4.5.2.2.CC | 1 + Tests/Conformance/C4.5.2.3.CC | 1 + Tests/Conformance/C4.5.3.1.CC | 1 + Tests/Conformance/C4.5.3.2.CC | 1 + Tests/Conformance/C4.5.3.3.CC | 1 + Tests/Conformance/C4.5.3.4.CC | 1 + Tests/Conformance/C4.5.4.1.CC | 1 + Tests/Conformance/C4.5.4.2.CC | 1 + Tests/Conformance/C4.6.1.1.CC | 1 + Tests/Conformance/C4.6.1.2.CC | 1 + Tests/Conformance/C4.6.2.1.CC | 1 + Tests/Conformance/C4.6.2.2.CC | 1 + Tests/Conformance/C4.6.3.1.CC | 1 + Tests/Conformance/C4.6.3.2.CC | 1 + Tests/Conformance/C4.6.4.1.CC | 1 + Tests/Conformance/C4.6.4.2.CC | 1 + Tests/Conformance/C4.6.4.3.CC | 1 + Tests/Conformance/C4.6.5.1.CC | 1 + Tests/Conformance/C4.6.6.1.CC | 1 + Tests/Conformance/C4.6.6.2.CC | 1 + Tests/Conformance/C4.6.7.1.CC | 1 + Tests/Conformance/C5.6.0.1.CC | 1 + Tests/Conformance/C6.2.3.1.CC | 1 + Tests/Conformance/C6.2.3.2.CC | 1 + Tests/Conformance/C6.2.3.3.CC | 1 + Tests/Conformance/C6.2.3.4.CC | 1 + Tests/Conformance/C7.10.0.1.CC | 1 + Tests/Conformance/C7.4.1.1.CC | 1 + Tests/Conformance/C7.4.4.1.CC | 1 + Tests/Conformance/C7.4.5.1.CC | 1 + Tests/Conformance/C7.5.1.1.CC | 1 + Tests/Conformance/C7.5.1.2.CC | 1 + Tests/Conformance/C7.5.1.3.CC | 1 + Tests/Conformance/C7.5.1.4.CC | 1 + Tests/Conformance/C7.5.1.5.CC | 1 + Tests/Conformance/C7.5.1.6.CC | 1 + Tests/Conformance/C7.5.5.1.CC | 1 + Tests/Conformance/C7.5.8.1.CC | 1 + Tests/Conformance/C7.5.9.1.CC | 1 + Tests/Conformance/C7.6.1.1.CC | 1 + Tests/Conformance/C7.6.1.2.CC | 1 + Tests/Conformance/C7.6.1.3.CC | 1 + Tests/Conformance/C7.6.2.1.CC | 1 + Tests/Conformance/C7.6.3.1.CC | 1 + Tests/Conformance/C7.6.4.1.CC | 1 + Tests/Conformance/C7.6.6.1.CC | 1 + Tests/Conformance/C7.6.7.1.CC | 1 + Tests/Conformance/C7.6.8.1.CC | 1 + Tests/Conformance/C7.7.1.1.CC | 1 + Tests/Conformance/C7.7.2.1.CC | 1 + Tests/Conformance/C7.8.0.1.CC | 1 + Tests/Conformance/C7.9.2.1.CC | 1 + Tests/Conformance/C7.9.2.2.CC | 1 + Tests/Conformance/C7.9.2.3.CC | 1 + Tests/Conformance/C7.9.2.4.CC | 1 + Tests/Conformance/C7.9.2.5.CC | 1 + Tests/Conformance/C7.9.2.6.CC | 1 + Tests/Conformance/C7.9.2.7.CC | 1 + Tests/Conformance/C7.9.2.8.CC | 1 + Tests/Conformance/C7.9.2.9.CC | 1 + Tests/Conformance/C8.7.0.1.CC | 1 + Tests/Conformance/C8.7.0.2.CC | 1 + Tests/Conformance/C8.7.0.3.CC | 1 + Tests/Conformance/C8.7.0.4.CC | 1 + Tests/Conformance/C8.7.0.5.CC | 1 + Tests/Conformance/C8.7.0.6.CC | 1 + Tests/Conformance/C8.8.0.1.CC | 1 + Tests/Conformance/C9.2.0.1.CC | 1 + Tests/Conformance/C9.3.0.1.CC | 1 + Tests/Conformance/C9.5.0.1.CC | 1 + Tests/Conformance/C9.5.0.2.CC | 1 + Tests/Conformance/C9.7.0.1.CC | 1 + Tests/Conformance/TEST | 1 + Tests/Conformance/TEST2 | 1 + Tests/Conformance/c14.4.0.1.cc | 1 + Tests/Conformance/c19.5.0.1.cc | 1 + Tests/Conformance/c24.0.3.cc | 1 + Tests/Conformance/c26.0.1.cc | 1 + Tests/Conformance/c6.2.3.5.cc | 1 + Tests/Conformance/doit | 1 + Tests/Conformance/doit2 | 1 + Tests/Deviance/D2.1.0.1.CC | 1 + Tests/Deviance/D2.2.0.2.CC | 1 + Tests/Deviance/D2.4.0.1.CC | 1 + Tests/Deviance/D2.5.0.1.CC | 1 + Tests/Deviance/D2.5.0.2.CC | 1 + Tests/Deviance/D2.7.1.1.CC | 1 + Tests/Deviance/D2.7.1.2.CC | 1 + Tests/Deviance/D2.7.2.1.CC | 1 + Tests/Deviance/D2.7.3.1.CC | 1 + Tests/Deviance/D2.7.3.2.CC | 1 + Tests/Deviance/D2.7.3.3.CC | 1 + Tests/Deviance/D2.7.4.1.CC | 1 + Tests/Deviance/D2.7.4.4.CC | 1 + Tests/Deviance/D25.0.1.CC | 1 + Tests/Deviance/D25.0.2.CC | 1 + Tests/Deviance/D3.3.1.1.CC | 1 + Tests/Deviance/D3.3.10.1.CC | 1 + Tests/Deviance/D3.3.2.1.CC | 1 + Tests/Deviance/D3.3.3.1.CC | 1 + Tests/Deviance/D3.3.4.1.CC | 1 + Tests/Deviance/D3.3.5.1.CC | 1 + Tests/Deviance/D3.4.0.1.CC | 1 + Tests/Deviance/D3.5.1.1.CC | 1 + Tests/Deviance/D3.5.2.1.CC | 1 + Tests/Deviance/D3.5.3.1.CC | 1 + Tests/Deviance/D3.5.5.1.CC | 1 + Tests/Deviance/D3401.DATA | 1 + Tests/Deviance/D4.2.1.1.CC | 1 + Tests/Deviance/D4.2.2.1.CC | 1 + Tests/Deviance/D4.2.3.1.CC | 1 + Tests/Deviance/D4.2.5.1.CC | 1 + Tests/Deviance/D4.2.9.1.CC | 1 + Tests/Deviance/D4.3.0.1.CC | 1 + Tests/Deviance/D4.4.1.1.CC | 1 + Tests/Deviance/D4.5.3.1.CC | 1 + Tests/Deviance/D4.6.0.1.CC | 1 + Tests/Deviance/D4.6.0.2.CC | 1 + Tests/Deviance/D4.6.1.1.CC | 1 + Tests/Deviance/D4.6.2.1.CC | 1 + Tests/Deviance/D4.6.3.1.CC | 1 + Tests/Deviance/D4.6.4.1.CC | 1 + Tests/Deviance/D4.6.5.1.CC | 1 + Tests/Deviance/D4.6.6.1.CC | 1 + Tests/Deviance/D4.6.7.1.CC | 1 + Tests/Deviance/D4.6.8.1.CC | 1 + Tests/Deviance/D7.1.1.1.CC | 1 + Tests/Deviance/D7.5.4.1.CC | 1 + Tests/Deviance/D7.6.1.1.CC | 1 + Tests/Deviance/D7.6.1.2.CC | 1 + Tests/Deviance/D7.6.1.3.CC | 1 + Tests/Deviance/D7.6.1.4.CC | 1 + Tests/Deviance/D7.6.3.1.CC | 1 + Tests/Deviance/D7.6.4.1.CC | 1 + Tests/Deviance/D7.6.6.1.CC | 1 + Tests/Deviance/D7.6.7.1.CC | 1 + Tests/Deviance/D7.6.8.1.CC | 1 + Tests/Deviance/D8.7.0.1.CC | 1 + Tests/Deviance/D8.8.0.1.CC | 1 + Tests/Deviance/D9.2.0.1.CC | 1 + Tests/Deviance/DOIT | 1 + Tests/Deviance/RUN.DEVIANCE | 1 + Tests/Deviance/TEST | 1 + Tests/Deviance/TEST2 | 1 + Tests/Spec.Conform/CFILE1 | 1 + Tests/Spec.Conform/LIBFILE2 | 1 + Tests/Spec.Conform/SPC13.2.0.1.CC | 1 + Tests/Spec.Conform/SPC13.4.0.1.CC | 1 + Tests/Spec.Conform/SPC17.16.0.1.CC | 1 + Tests/Spec.Conform/SPC17.2.0.1.CC | 1 + Tests/Spec.Conform/SPC17.2.0.2.CC | 1 + Tests/Spec.Conform/SPC17.2.0.3.CC | 1 + Tests/Spec.Conform/SPC17.3.0.1.CC | 1 + Tests/Spec.Conform/SPC17.3.0.2.CC | 1 + Tests/Spec.Conform/SPC17.3.0.3.CC | 1 + Tests/Spec.Conform/SPC17.3.0.4.CC | 1 + Tests/Spec.Conform/SPC17.3.0.5.CC | 1 + Tests/Spec.Conform/SPC17.6.0.1.CC | 1 + Tests/Spec.Conform/SPC17.7.0.1.CC | 1 + Tests/Spec.Conform/SPC2.1.0.1.CC | 1 + Tests/Spec.Conform/SPC20.2.0.1.CC | 1 + Tests/Spec.Conform/SPC21.1.0.1.CC | 1 + Tests/Spec.Conform/SPC21.2.0.1.CC | 1 + Tests/Spec.Conform/SPC22.1.0.1.CC | 1 + Tests/Spec.Conform/SPC22.101.EXEC | 1 + Tests/Spec.Conform/SPC23.2.0.1.CC | 1 + Tests/Spec.Conform/SPC23.201.EXEC | 1 + Tests/Spec.Conform/SPC25.0.1.CC | 1 + Tests/Spec.Conform/SPC25.0.2.CC | 1 + Tests/Spec.Conform/SPC25.1.1.CC | 1 + Tests/Spec.Conform/SPC25.1.EXEC | 1 + Tests/Spec.Conform/SPC25.1.H | 1 + Tests/Spec.Conform/SPC25.2.1.CC | 1 + Tests/Spec.Conform/SPC25.2.EXEC | 1 + Tests/Spec.Conform/SPC3.3.4.1.CC | 1 + Tests/Spec.Conform/SPC3.4.0.1.CC | 1 + Tests/Spec.Conform/SPC3.4.0.2.CC | 1 + Tests/Spec.Conform/SPC3.6.0.1.CC | 1 + Tests/Spec.Conform/SPC3.6.0.2.CC | 1 + Tests/Spec.Conform/SPC3.6.0.3.CC | 1 + Tests/Spec.Conform/SPC3401.EXEC | 1 + Tests/Spec.Conform/SPC34021 | 1 + Tests/Spec.Conform/SPC34022 | 1 + Tests/Spec.Conform/SPC34023 | 1 + Tests/Spec.Conform/SPC34024 | 1 + Tests/Spec.Conform/SPC34025 | 1 + Tests/Spec.Conform/SPC34026 | 1 + Tests/Spec.Conform/SPC34027 | 1 + Tests/Spec.Conform/SPC34028 | 1 + Tests/Spec.Conform/SPC4.3.0.1.CC | 1 + Tests/Spec.Conform/SPC4.3.1.1.CC | 1 + Tests/Spec.Conform/SPC4.4.1.1.CC | 1 + Tests/Spec.Conform/SPC4.5.2.1.CC | 1 + Tests/Spec.Conform/SPC4.5.3.1.CC | 1 + Tests/Spec.Conform/SPC4.5.3.2.CC | 1 + Tests/Spec.Conform/SPC4.6.3.1.CC | 1 + Tests/Spec.Conform/SPC4.6.3.2.CC | 1 + Tests/Spec.Conform/SPC4.6.3.3.CC | 1 + Tests/Spec.Conform/SPC4.6.3.4.CC | 1 + Tests/Spec.Conform/SPC4.6.3.5.CC | 1 + Tests/Spec.Conform/SPC4.6.3.6.CC | 1 + Tests/Spec.Conform/SPC4301.1.CC | 1 + Tests/Spec.Conform/SPC4301.2.CC | 1 + Tests/Spec.Conform/SPC4301.EXEC | 1 + Tests/Spec.Conform/SPC4301.H | 1 + Tests/Spec.Conform/SPC4311.1.CC | 1 + Tests/Spec.Conform/SPC4311.EXEC | 1 + Tests/Spec.Conform/SPC4411.1.CC | 1 + Tests/Spec.Conform/SPC4521.1.CC | 1 + Tests/Spec.Conform/SPC4521.EXEC | 1 + Tests/Spec.Conform/SPC4521.H | 1 + Tests/Spec.Conform/SPC4531.1.CC | 1 + Tests/Spec.Conform/SPC4531.EXEC | 1 + Tests/Spec.Conform/SPC4531.H | 1 + Tests/Spec.Conform/SPC4532.1.CC | 1 + Tests/Spec.Conform/SPC4532.EXEC | 1 + Tests/Spec.Conform/SPC4532.H | 1 + Tests/Spec.Conform/SPC4631.1.CC | 1 + Tests/Spec.Conform/SPC4631.EXEC | 1 + Tests/Spec.Conform/SPC4632.1.CC | 1 + Tests/Spec.Conform/SPC4632.EXEC | 1 + Tests/Spec.Conform/SPC4633.1.CC | 1 + Tests/Spec.Conform/SPC4633.EXEC | 1 + Tests/Spec.Conform/SPC4634.1.CC | 1 + Tests/Spec.Conform/SPC4634.EXEC | 1 + Tests/Spec.Conform/SPC4636.1.CC | 1 + Tests/Spec.Conform/SPC4636.EXEC | 1 + Tests/Spec.Conform/UFILE1 | 1 + Tests/Spec.Conform/USERFILE2 | 1 + Tests/Spec.Conform/spc21.3.0.1.cc | 1 + Tests/Spec.Conform/spc21.3.0.2.cc | 1 + Tests/Spec.Conform/spc21.3.0.3.cc | 1 + Tests/Spec.Conform/spc4411.exec | 1 + Tests/Spec.Deviance/DOIT | 1 + Tests/Spec.Deviance/SPD17.2.0.1.CC | 1 + Tests/Spec.Deviance/SPD17.2.0.2.CC | 1 + Tests/Spec.Deviance/SPD17.2.0.3.CC | 1 + Tests/Spec.Deviance/SPD17.2.0.4.CC | 1 + Tests/Spec.Deviance/SPD17.2.0.5.CC | 1 + Tests/Spec.Deviance/SPD17.2.0.7.CC | 1 + Tests/Spec.Deviance/SPD17.3.0.1.CC | 1 + Tests/Spec.Deviance/SPD17.3.0.2.CC | 1 + Tests/Spec.Deviance/SPD17.3.0.3.CC | 1 + Tests/Spec.Deviance/SPD17.5.0.1.CC | 1 + Tests/Spec.Deviance/SPD17.5.0.2.CC | 1 + Tests/Spec.Deviance/SPD17.6.0.1.CC | 1 + Tests/Spec.Deviance/SPD17.6.0.2.CC | 1 + Tests/Spec.Deviance/SPD17.6.0.3.CC | 1 + Tests/Spec.Deviance/SPD17.7.0.1.CC | 1 + Tests/Spec.Deviance/TEST | 1 + backup | 1 + cc.notes | 1 + count | 1 + linkit | 1 + linkit2 | 1 + make | 1 + make2 | 1 + obj/README.txt | 1 + smake | 1 + 501 files changed, 529 insertions(+) create mode 100755 Asm.pas create mode 100755 CC.pas create mode 100755 CC.rez create mode 100755 CC.rez2 create mode 100755 CCommon.asm create mode 100755 CCommon.macros create mode 100755 CCommon.pas create mode 100755 CGC.asm create mode 100755 CGC.macros create mode 100755 CGC.pas create mode 100755 CGI.Comments create mode 100755 CGI.Debug create mode 100755 CGI.pas create mode 100755 DAG.pas create mode 100755 DAG2.pas create mode 100755 Exp.macros create mode 100755 Expression.asm create mode 100755 Expression.pas create mode 100755 Gen.pas create mode 100755 Header.pas create mode 100755 Header2.pas create mode 100644 LICENSE create mode 100755 MM.asm create mode 100755 MM.macros create mode 100755 MM.pas create mode 100755 Native.asm create mode 100755 Native.macros create mode 100755 Native.pas create mode 100755 Native2.pas create mode 100755 ObjOut.asm create mode 100755 ObjOut.macros create mode 100755 ObjOut.pas create mode 100755 ObjOut2.asm create mode 100755 ObjOut2.pas create mode 100755 Parser.pas create mode 100644 README.md create mode 100755 Scanner.asm create mode 100755 Scanner.debug create mode 100755 Scanner.macros create mode 100755 Scanner.pas create mode 100755 Symbol.Print create mode 100755 Symbol.asm create mode 100755 Symbol.macros create mode 100755 Symbol.pas create mode 100755 Table.asm create mode 100755 Table.macros create mode 100755 Table.pas create mode 100755 Tests/Conformance/C11.4.2.1.CC create mode 100755 Tests/Conformance/C13.1.0.1.CC create mode 100755 Tests/Conformance/C14.1.0.1.CC create mode 100755 Tests/Conformance/C14.2.0.1.CC create mode 100755 Tests/Conformance/C14.3.0.1.CC create mode 100755 Tests/Conformance/C14.5.0.1.CC create mode 100755 Tests/Conformance/C14.6.0.1.CC create mode 100755 Tests/Conformance/C14.7.0.1.CC create mode 100755 Tests/Conformance/C14.8.0.1.CC create mode 100755 Tests/Conformance/C14.9.0.1.CC create mode 100755 Tests/Conformance/C15.1.0.1.CC create mode 100755 Tests/Conformance/C15.2.0.1.CC create mode 100755 Tests/Conformance/C15.3.0.1.CC create mode 100755 Tests/Conformance/C15.5.0.1.CC create mode 100755 Tests/Conformance/C15.6.0.1.CC create mode 100755 Tests/Conformance/C15.7.0.1.CC create mode 100755 Tests/Conformance/C15.7.0.2.CC create mode 100755 Tests/Conformance/C15.8.0.1.CC create mode 100755 Tests/Conformance/C15.8.0.2.CC create mode 100755 Tests/Conformance/C15.9.0.1.CC create mode 100755 Tests/Conformance/C16.1.0.1.CC create mode 100755 Tests/Conformance/C16.4.0.1.CC create mode 100755 Tests/Conformance/C17.10.0.1.CC create mode 100755 Tests/Conformance/C17.11.0.1.CC create mode 100755 Tests/Conformance/C17.11.0.10.CC create mode 100755 Tests/Conformance/C17.11.0.11.CC create mode 100755 Tests/Conformance/C17.11.0.2.CC create mode 100755 Tests/Conformance/C17.11.0.3.CC create mode 100755 Tests/Conformance/C17.11.0.4.CC create mode 100755 Tests/Conformance/C17.11.0.5.CC create mode 100755 Tests/Conformance/C17.11.0.6.CC create mode 100755 Tests/Conformance/C17.11.0.7.CC create mode 100755 Tests/Conformance/C17.11.0.8.CC create mode 100755 Tests/Conformance/C17.11.0.9.CC create mode 100755 Tests/Conformance/C17.13.0.1.CC create mode 100755 Tests/Conformance/C17.14.0.1.CC create mode 100755 Tests/Conformance/C17.15.0.1.CC create mode 100755 Tests/Conformance/C17.16.0.1.CC create mode 100755 Tests/Conformance/C17.5.0.1.CC create mode 100755 Tests/Conformance/C17.5.0.2.CC create mode 100755 Tests/Conformance/C17.6.0.1.CC create mode 100755 Tests/Conformance/C17.6.0.2.CC create mode 100755 Tests/Conformance/C17.7.0.1.CC create mode 100755 Tests/Conformance/C17.7.0.2.CC create mode 100755 Tests/Conformance/C17.8.0.1.CC create mode 100755 Tests/Conformance/C17.8.0.10.CC create mode 100755 Tests/Conformance/C17.8.0.11.CC create mode 100755 Tests/Conformance/C17.8.0.12.CC create mode 100755 Tests/Conformance/C17.8.0.13.CC create mode 100755 Tests/Conformance/C17.8.0.14.CC create mode 100755 Tests/Conformance/C17.8.0.15.CC create mode 100755 Tests/Conformance/C17.8.0.16.CC create mode 100755 Tests/Conformance/C17.8.0.17.CC create mode 100755 Tests/Conformance/C17.8.0.18.CC create mode 100755 Tests/Conformance/C17.8.0.19.CC create mode 100755 Tests/Conformance/C17.8.0.2.CC create mode 100755 Tests/Conformance/C17.8.0.20.CC create mode 100755 Tests/Conformance/C17.8.0.21.CC create mode 100755 Tests/Conformance/C17.8.0.22.CC create mode 100755 Tests/Conformance/C17.8.0.23.CC create mode 100755 Tests/Conformance/C17.8.0.24.CC create mode 100755 Tests/Conformance/C17.8.0.3.CC create mode 100755 Tests/Conformance/C17.8.0.4.CC create mode 100755 Tests/Conformance/C17.8.0.5.CC create mode 100755 Tests/Conformance/C17.8.0.6.CC create mode 100755 Tests/Conformance/C17.8.0.7.CC create mode 100755 Tests/Conformance/C17.8.0.8.CC create mode 100755 Tests/Conformance/C17.8.0.9.CC create mode 100755 Tests/Conformance/C17.9.0.1.CC create mode 100755 Tests/Conformance/C18.1.0.1.CC create mode 100755 Tests/Conformance/C18.3.0.1.CC create mode 100755 Tests/Conformance/C19.1.0.1.CC create mode 100755 Tests/Conformance/C19.10.0.1.CC create mode 100755 Tests/Conformance/C19.2.0.1.CC create mode 100755 Tests/Conformance/C19.3.0.1.CC create mode 100755 Tests/Conformance/C19.4.0.1.CC create mode 100755 Tests/Conformance/C19.6.0.1.CC create mode 100755 Tests/Conformance/C19.7.0.1.CC create mode 100755 Tests/Conformance/C19.8.0.1.CC create mode 100755 Tests/Conformance/C19.9.0.1.CC create mode 100755 Tests/Conformance/C2.1.0.1.CC create mode 100755 Tests/Conformance/C2.1.0.2.CC create mode 100755 Tests/Conformance/C2.1.0.3.CC create mode 100755 Tests/Conformance/C2.1.0.4.CC create mode 100755 Tests/Conformance/C2.1.1.1.CC create mode 100755 Tests/Conformance/C2.1.1.2.CC create mode 100755 Tests/Conformance/C2.1.2.1.CC create mode 100755 Tests/Conformance/C2.1.2.2.CC create mode 100755 Tests/Conformance/C2.1.2.3.CC create mode 100755 Tests/Conformance/C2.2.0.1.CC create mode 100755 Tests/Conformance/C2.2.0.2.CC create mode 100755 Tests/Conformance/C2.2.0.3.CC create mode 100755 Tests/Conformance/C2.2.0.4.CC create mode 100755 Tests/Conformance/C2.4.0.1.CC create mode 100755 Tests/Conformance/C2.4.0.2.CC create mode 100755 Tests/Conformance/C2.5.0.1.CC create mode 100755 Tests/Conformance/C2.5.0.2.CC create mode 100755 Tests/Conformance/C2.5.0.3.CC create mode 100755 Tests/Conformance/C2.5.0.4.CC create mode 100755 Tests/Conformance/C2.5.0.5.CC create mode 100755 Tests/Conformance/C2.5.0.6.CC create mode 100755 Tests/Conformance/C2.5.0.7.CC create mode 100755 Tests/Conformance/C2.5.0.8.CC create mode 100755 Tests/Conformance/C2.6.0.1.CC create mode 100755 Tests/Conformance/C2.6.0.2.CC create mode 100755 Tests/Conformance/C2.6.0.3.CC create mode 100755 Tests/Conformance/C2.6.0.4.CC create mode 100755 Tests/Conformance/C2.6.0.5.CC create mode 100755 Tests/Conformance/C2.7.1.1.CC create mode 100755 Tests/Conformance/C2.7.1.2.CC create mode 100755 Tests/Conformance/C2.7.1.3.CC create mode 100755 Tests/Conformance/C2.7.1.4.CC create mode 100755 Tests/Conformance/C2.7.1.5.CC create mode 100755 Tests/Conformance/C2.7.1.6.CC create mode 100755 Tests/Conformance/C2.7.1.7.CC create mode 100755 Tests/Conformance/C2.7.1.8.CC create mode 100755 Tests/Conformance/C2.7.2.1.CC create mode 100755 Tests/Conformance/C2.7.2.2.CC create mode 100755 Tests/Conformance/C2.7.2.3.CC create mode 100755 Tests/Conformance/C2.7.3.1.CC create mode 100755 Tests/Conformance/C2.7.3.2.CC create mode 100755 Tests/Conformance/C2.7.4.1.CC create mode 100755 Tests/Conformance/C2.7.4.2.CC create mode 100755 Tests/Conformance/C2.7.4.3.CC create mode 100755 Tests/Conformance/C2.7.4.4.CC create mode 100755 Tests/Conformance/C2.7.7.1.CC create mode 100755 Tests/Conformance/C2.7.7.2.CC create mode 100755 Tests/Conformance/C20.1.0.1.CC create mode 100755 Tests/Conformance/C20.5.0.1.CC create mode 100755 Tests/Conformance/C21.1.0.2.CC create mode 100755 Tests/Conformance/C21.4.0.1.CC create mode 100755 Tests/Conformance/C22.5.0.1.CC create mode 100755 Tests/Conformance/C23.1.0.1.CC create mode 100755 Tests/Conformance/C23.2.0.1.CC create mode 100755 Tests/Conformance/C23.3.0.1.CC create mode 100755 Tests/Conformance/C23.4.0.1.CC create mode 100755 Tests/Conformance/C23.5.0.1.CC create mode 100755 Tests/Conformance/C23.6.0.1.CC create mode 100755 Tests/Conformance/C24.0.1.CC create mode 100755 Tests/Conformance/C24.0.2.CC create mode 100755 Tests/Conformance/C25.0.1.CC create mode 100755 Tests/Conformance/C25.0.10.CC create mode 100755 Tests/Conformance/C25.0.11.CC create mode 100755 Tests/Conformance/C25.0.12.CC create mode 100755 Tests/Conformance/C25.0.13.CC create mode 100755 Tests/Conformance/C25.0.14.CC create mode 100755 Tests/Conformance/C25.0.15.CC create mode 100755 Tests/Conformance/C25.0.16.CC create mode 100755 Tests/Conformance/C25.0.17.CC create mode 100755 Tests/Conformance/C25.0.18.CC create mode 100755 Tests/Conformance/C25.0.19.CC create mode 100755 Tests/Conformance/C25.0.2.CC create mode 100755 Tests/Conformance/C25.0.20.CC create mode 100755 Tests/Conformance/C25.0.21.CC create mode 100755 Tests/Conformance/C25.0.22.CC create mode 100755 Tests/Conformance/C25.0.23.CC create mode 100755 Tests/Conformance/C25.0.24.CC create mode 100755 Tests/Conformance/C25.0.25.CC create mode 100755 Tests/Conformance/C25.0.26.CC create mode 100755 Tests/Conformance/C25.0.3.CC create mode 100755 Tests/Conformance/C25.0.4.CC create mode 100755 Tests/Conformance/C25.0.5.CC create mode 100755 Tests/Conformance/C25.0.6.CC create mode 100755 Tests/Conformance/C25.0.7.CC create mode 100755 Tests/Conformance/C25.0.8.CC create mode 100755 Tests/Conformance/C25.0.9.CC create mode 100755 Tests/Conformance/C3.3.0.1.CC create mode 100755 Tests/Conformance/C3.3.1.1.CC create mode 100755 Tests/Conformance/C3.3.2.1.CC create mode 100755 Tests/Conformance/C3.3.3.1.CC create mode 100755 Tests/Conformance/C3.3.4.1.CC create mode 100755 Tests/Conformance/C3.3.5.1.CC create mode 100755 Tests/Conformance/C3.3.6.1.CC create mode 100755 Tests/Conformance/C3.3.8.1.CC create mode 100755 Tests/Conformance/C3.3.9.1.CC create mode 100755 Tests/Conformance/C3.5.1.1.CC create mode 100755 Tests/Conformance/C3.5.1.2.CC create mode 100755 Tests/Conformance/C3.5.1.3.CC create mode 100755 Tests/Conformance/C3.5.1.4.CC create mode 100755 Tests/Conformance/C3.5.1.5.CC create mode 100755 Tests/Conformance/C3.5.2.1.CC create mode 100755 Tests/Conformance/C3.5.2.2.CC create mode 100755 Tests/Conformance/C3.5.2.3.CC create mode 100755 Tests/Conformance/C3.5.2.4.CC create mode 100755 Tests/Conformance/C3.5.3.1.CC create mode 100755 Tests/Conformance/C3.5.4.1.CC create mode 100755 Tests/Conformance/C3.5.4.2.CC create mode 100755 Tests/Conformance/C4.2.1.1.CC create mode 100755 Tests/Conformance/C4.2.2.1.CC create mode 100755 Tests/Conformance/C4.2.4.1.CC create mode 100755 Tests/Conformance/C4.2.5.1.CC create mode 100755 Tests/Conformance/C4.3.0.1.CC create mode 100755 Tests/Conformance/C4.3.0.2.CC create mode 100755 Tests/Conformance/C4.4.2.1.CC create mode 100755 Tests/Conformance/C4.5.2.1.CC create mode 100755 Tests/Conformance/C4.5.2.2.CC create mode 100755 Tests/Conformance/C4.5.2.3.CC create mode 100755 Tests/Conformance/C4.5.3.1.CC create mode 100755 Tests/Conformance/C4.5.3.2.CC create mode 100755 Tests/Conformance/C4.5.3.3.CC create mode 100755 Tests/Conformance/C4.5.3.4.CC create mode 100755 Tests/Conformance/C4.5.4.1.CC create mode 100755 Tests/Conformance/C4.5.4.2.CC create mode 100755 Tests/Conformance/C4.6.1.1.CC create mode 100755 Tests/Conformance/C4.6.1.2.CC create mode 100755 Tests/Conformance/C4.6.2.1.CC create mode 100755 Tests/Conformance/C4.6.2.2.CC create mode 100755 Tests/Conformance/C4.6.3.1.CC create mode 100755 Tests/Conformance/C4.6.3.2.CC create mode 100755 Tests/Conformance/C4.6.4.1.CC create mode 100755 Tests/Conformance/C4.6.4.2.CC create mode 100755 Tests/Conformance/C4.6.4.3.CC create mode 100755 Tests/Conformance/C4.6.5.1.CC create mode 100755 Tests/Conformance/C4.6.6.1.CC create mode 100755 Tests/Conformance/C4.6.6.2.CC create mode 100755 Tests/Conformance/C4.6.7.1.CC create mode 100755 Tests/Conformance/C5.6.0.1.CC create mode 100755 Tests/Conformance/C6.2.3.1.CC create mode 100755 Tests/Conformance/C6.2.3.2.CC create mode 100755 Tests/Conformance/C6.2.3.3.CC create mode 100755 Tests/Conformance/C6.2.3.4.CC create mode 100755 Tests/Conformance/C7.10.0.1.CC create mode 100755 Tests/Conformance/C7.4.1.1.CC create mode 100755 Tests/Conformance/C7.4.4.1.CC create mode 100755 Tests/Conformance/C7.4.5.1.CC create mode 100755 Tests/Conformance/C7.5.1.1.CC create mode 100755 Tests/Conformance/C7.5.1.2.CC create mode 100755 Tests/Conformance/C7.5.1.3.CC create mode 100755 Tests/Conformance/C7.5.1.4.CC create mode 100755 Tests/Conformance/C7.5.1.5.CC create mode 100755 Tests/Conformance/C7.5.1.6.CC create mode 100755 Tests/Conformance/C7.5.5.1.CC create mode 100755 Tests/Conformance/C7.5.8.1.CC create mode 100755 Tests/Conformance/C7.5.9.1.CC create mode 100755 Tests/Conformance/C7.6.1.1.CC create mode 100755 Tests/Conformance/C7.6.1.2.CC create mode 100755 Tests/Conformance/C7.6.1.3.CC create mode 100755 Tests/Conformance/C7.6.2.1.CC create mode 100755 Tests/Conformance/C7.6.3.1.CC create mode 100755 Tests/Conformance/C7.6.4.1.CC create mode 100755 Tests/Conformance/C7.6.6.1.CC create mode 100755 Tests/Conformance/C7.6.7.1.CC create mode 100755 Tests/Conformance/C7.6.8.1.CC create mode 100755 Tests/Conformance/C7.7.1.1.CC create mode 100755 Tests/Conformance/C7.7.2.1.CC create mode 100755 Tests/Conformance/C7.8.0.1.CC create mode 100755 Tests/Conformance/C7.9.2.1.CC create mode 100755 Tests/Conformance/C7.9.2.2.CC create mode 100755 Tests/Conformance/C7.9.2.3.CC create mode 100755 Tests/Conformance/C7.9.2.4.CC create mode 100755 Tests/Conformance/C7.9.2.5.CC create mode 100755 Tests/Conformance/C7.9.2.6.CC create mode 100755 Tests/Conformance/C7.9.2.7.CC create mode 100755 Tests/Conformance/C7.9.2.8.CC create mode 100755 Tests/Conformance/C7.9.2.9.CC create mode 100755 Tests/Conformance/C8.7.0.1.CC create mode 100755 Tests/Conformance/C8.7.0.2.CC create mode 100755 Tests/Conformance/C8.7.0.3.CC create mode 100755 Tests/Conformance/C8.7.0.4.CC create mode 100755 Tests/Conformance/C8.7.0.5.CC create mode 100755 Tests/Conformance/C8.7.0.6.CC create mode 100755 Tests/Conformance/C8.8.0.1.CC create mode 100755 Tests/Conformance/C9.2.0.1.CC create mode 100755 Tests/Conformance/C9.3.0.1.CC create mode 100755 Tests/Conformance/C9.5.0.1.CC create mode 100755 Tests/Conformance/C9.5.0.2.CC create mode 100755 Tests/Conformance/C9.7.0.1.CC create mode 100755 Tests/Conformance/TEST create mode 100755 Tests/Conformance/TEST2 create mode 100755 Tests/Conformance/c14.4.0.1.cc create mode 100755 Tests/Conformance/c19.5.0.1.cc create mode 100755 Tests/Conformance/c24.0.3.cc create mode 100755 Tests/Conformance/c26.0.1.cc create mode 100755 Tests/Conformance/c6.2.3.5.cc create mode 100755 Tests/Conformance/doit create mode 100755 Tests/Conformance/doit2 create mode 100755 Tests/Deviance/D2.1.0.1.CC create mode 100755 Tests/Deviance/D2.2.0.2.CC create mode 100755 Tests/Deviance/D2.4.0.1.CC create mode 100755 Tests/Deviance/D2.5.0.1.CC create mode 100755 Tests/Deviance/D2.5.0.2.CC create mode 100755 Tests/Deviance/D2.7.1.1.CC create mode 100755 Tests/Deviance/D2.7.1.2.CC create mode 100755 Tests/Deviance/D2.7.2.1.CC create mode 100755 Tests/Deviance/D2.7.3.1.CC create mode 100755 Tests/Deviance/D2.7.3.2.CC create mode 100755 Tests/Deviance/D2.7.3.3.CC create mode 100755 Tests/Deviance/D2.7.4.1.CC create mode 100755 Tests/Deviance/D2.7.4.4.CC create mode 100755 Tests/Deviance/D25.0.1.CC create mode 100755 Tests/Deviance/D25.0.2.CC create mode 100755 Tests/Deviance/D3.3.1.1.CC create mode 100755 Tests/Deviance/D3.3.10.1.CC create mode 100755 Tests/Deviance/D3.3.2.1.CC create mode 100755 Tests/Deviance/D3.3.3.1.CC create mode 100755 Tests/Deviance/D3.3.4.1.CC create mode 100755 Tests/Deviance/D3.3.5.1.CC create mode 100755 Tests/Deviance/D3.4.0.1.CC create mode 100755 Tests/Deviance/D3.5.1.1.CC create mode 100755 Tests/Deviance/D3.5.2.1.CC create mode 100755 Tests/Deviance/D3.5.3.1.CC create mode 100755 Tests/Deviance/D3.5.5.1.CC create mode 100755 Tests/Deviance/D3401.DATA create mode 100755 Tests/Deviance/D4.2.1.1.CC create mode 100755 Tests/Deviance/D4.2.2.1.CC create mode 100755 Tests/Deviance/D4.2.3.1.CC create mode 100755 Tests/Deviance/D4.2.5.1.CC create mode 100755 Tests/Deviance/D4.2.9.1.CC create mode 100755 Tests/Deviance/D4.3.0.1.CC create mode 100755 Tests/Deviance/D4.4.1.1.CC create mode 100755 Tests/Deviance/D4.5.3.1.CC create mode 100755 Tests/Deviance/D4.6.0.1.CC create mode 100755 Tests/Deviance/D4.6.0.2.CC create mode 100755 Tests/Deviance/D4.6.1.1.CC create mode 100755 Tests/Deviance/D4.6.2.1.CC create mode 100755 Tests/Deviance/D4.6.3.1.CC create mode 100755 Tests/Deviance/D4.6.4.1.CC create mode 100755 Tests/Deviance/D4.6.5.1.CC create mode 100755 Tests/Deviance/D4.6.6.1.CC create mode 100755 Tests/Deviance/D4.6.7.1.CC create mode 100755 Tests/Deviance/D4.6.8.1.CC create mode 100755 Tests/Deviance/D7.1.1.1.CC create mode 100755 Tests/Deviance/D7.5.4.1.CC create mode 100755 Tests/Deviance/D7.6.1.1.CC create mode 100755 Tests/Deviance/D7.6.1.2.CC create mode 100755 Tests/Deviance/D7.6.1.3.CC create mode 100755 Tests/Deviance/D7.6.1.4.CC create mode 100755 Tests/Deviance/D7.6.3.1.CC create mode 100755 Tests/Deviance/D7.6.4.1.CC create mode 100755 Tests/Deviance/D7.6.6.1.CC create mode 100755 Tests/Deviance/D7.6.7.1.CC create mode 100755 Tests/Deviance/D7.6.8.1.CC create mode 100755 Tests/Deviance/D8.7.0.1.CC create mode 100755 Tests/Deviance/D8.8.0.1.CC create mode 100755 Tests/Deviance/D9.2.0.1.CC create mode 100755 Tests/Deviance/DOIT create mode 100755 Tests/Deviance/RUN.DEVIANCE create mode 100755 Tests/Deviance/TEST create mode 100755 Tests/Deviance/TEST2 create mode 100755 Tests/Spec.Conform/CFILE1 create mode 100755 Tests/Spec.Conform/LIBFILE2 create mode 100755 Tests/Spec.Conform/SPC13.2.0.1.CC create mode 100755 Tests/Spec.Conform/SPC13.4.0.1.CC create mode 100755 Tests/Spec.Conform/SPC17.16.0.1.CC create mode 100755 Tests/Spec.Conform/SPC17.2.0.1.CC create mode 100755 Tests/Spec.Conform/SPC17.2.0.2.CC create mode 100755 Tests/Spec.Conform/SPC17.2.0.3.CC create mode 100755 Tests/Spec.Conform/SPC17.3.0.1.CC create mode 100755 Tests/Spec.Conform/SPC17.3.0.2.CC create mode 100755 Tests/Spec.Conform/SPC17.3.0.3.CC create mode 100755 Tests/Spec.Conform/SPC17.3.0.4.CC create mode 100755 Tests/Spec.Conform/SPC17.3.0.5.CC create mode 100755 Tests/Spec.Conform/SPC17.6.0.1.CC create mode 100755 Tests/Spec.Conform/SPC17.7.0.1.CC create mode 100755 Tests/Spec.Conform/SPC2.1.0.1.CC create mode 100755 Tests/Spec.Conform/SPC20.2.0.1.CC create mode 100755 Tests/Spec.Conform/SPC21.1.0.1.CC create mode 100755 Tests/Spec.Conform/SPC21.2.0.1.CC create mode 100755 Tests/Spec.Conform/SPC22.1.0.1.CC create mode 100755 Tests/Spec.Conform/SPC22.101.EXEC create mode 100755 Tests/Spec.Conform/SPC23.2.0.1.CC create mode 100755 Tests/Spec.Conform/SPC23.201.EXEC create mode 100755 Tests/Spec.Conform/SPC25.0.1.CC create mode 100755 Tests/Spec.Conform/SPC25.0.2.CC create mode 100755 Tests/Spec.Conform/SPC25.1.1.CC create mode 100755 Tests/Spec.Conform/SPC25.1.EXEC create mode 100755 Tests/Spec.Conform/SPC25.1.H create mode 100755 Tests/Spec.Conform/SPC25.2.1.CC create mode 100755 Tests/Spec.Conform/SPC25.2.EXEC create mode 100755 Tests/Spec.Conform/SPC3.3.4.1.CC create mode 100755 Tests/Spec.Conform/SPC3.4.0.1.CC create mode 100755 Tests/Spec.Conform/SPC3.4.0.2.CC create mode 100755 Tests/Spec.Conform/SPC3.6.0.1.CC create mode 100755 Tests/Spec.Conform/SPC3.6.0.2.CC create mode 100755 Tests/Spec.Conform/SPC3.6.0.3.CC create mode 100755 Tests/Spec.Conform/SPC3401.EXEC create mode 100755 Tests/Spec.Conform/SPC34021 create mode 100755 Tests/Spec.Conform/SPC34022 create mode 100755 Tests/Spec.Conform/SPC34023 create mode 100755 Tests/Spec.Conform/SPC34024 create mode 100755 Tests/Spec.Conform/SPC34025 create mode 100755 Tests/Spec.Conform/SPC34026 create mode 100755 Tests/Spec.Conform/SPC34027 create mode 100755 Tests/Spec.Conform/SPC34028 create mode 100755 Tests/Spec.Conform/SPC4.3.0.1.CC create mode 100755 Tests/Spec.Conform/SPC4.3.1.1.CC create mode 100755 Tests/Spec.Conform/SPC4.4.1.1.CC create mode 100755 Tests/Spec.Conform/SPC4.5.2.1.CC create mode 100755 Tests/Spec.Conform/SPC4.5.3.1.CC create mode 100755 Tests/Spec.Conform/SPC4.5.3.2.CC create mode 100755 Tests/Spec.Conform/SPC4.6.3.1.CC create mode 100755 Tests/Spec.Conform/SPC4.6.3.2.CC create mode 100755 Tests/Spec.Conform/SPC4.6.3.3.CC create mode 100755 Tests/Spec.Conform/SPC4.6.3.4.CC create mode 100755 Tests/Spec.Conform/SPC4.6.3.5.CC create mode 100755 Tests/Spec.Conform/SPC4.6.3.6.CC create mode 100755 Tests/Spec.Conform/SPC4301.1.CC create mode 100755 Tests/Spec.Conform/SPC4301.2.CC create mode 100755 Tests/Spec.Conform/SPC4301.EXEC create mode 100755 Tests/Spec.Conform/SPC4301.H create mode 100755 Tests/Spec.Conform/SPC4311.1.CC create mode 100755 Tests/Spec.Conform/SPC4311.EXEC create mode 100755 Tests/Spec.Conform/SPC4411.1.CC create mode 100755 Tests/Spec.Conform/SPC4521.1.CC create mode 100755 Tests/Spec.Conform/SPC4521.EXEC create mode 100755 Tests/Spec.Conform/SPC4521.H create mode 100755 Tests/Spec.Conform/SPC4531.1.CC create mode 100755 Tests/Spec.Conform/SPC4531.EXEC create mode 100755 Tests/Spec.Conform/SPC4531.H create mode 100755 Tests/Spec.Conform/SPC4532.1.CC create mode 100755 Tests/Spec.Conform/SPC4532.EXEC create mode 100755 Tests/Spec.Conform/SPC4532.H create mode 100755 Tests/Spec.Conform/SPC4631.1.CC create mode 100755 Tests/Spec.Conform/SPC4631.EXEC create mode 100755 Tests/Spec.Conform/SPC4632.1.CC create mode 100755 Tests/Spec.Conform/SPC4632.EXEC create mode 100755 Tests/Spec.Conform/SPC4633.1.CC create mode 100755 Tests/Spec.Conform/SPC4633.EXEC create mode 100755 Tests/Spec.Conform/SPC4634.1.CC create mode 100755 Tests/Spec.Conform/SPC4634.EXEC create mode 100755 Tests/Spec.Conform/SPC4636.1.CC create mode 100755 Tests/Spec.Conform/SPC4636.EXEC create mode 100755 Tests/Spec.Conform/UFILE1 create mode 100755 Tests/Spec.Conform/USERFILE2 create mode 100755 Tests/Spec.Conform/spc21.3.0.1.cc create mode 100755 Tests/Spec.Conform/spc21.3.0.2.cc create mode 100755 Tests/Spec.Conform/spc21.3.0.3.cc create mode 100755 Tests/Spec.Conform/spc4411.exec create mode 100755 Tests/Spec.Deviance/DOIT create mode 100755 Tests/Spec.Deviance/SPD17.2.0.1.CC create mode 100755 Tests/Spec.Deviance/SPD17.2.0.2.CC create mode 100755 Tests/Spec.Deviance/SPD17.2.0.3.CC create mode 100755 Tests/Spec.Deviance/SPD17.2.0.4.CC create mode 100755 Tests/Spec.Deviance/SPD17.2.0.5.CC create mode 100755 Tests/Spec.Deviance/SPD17.2.0.7.CC create mode 100755 Tests/Spec.Deviance/SPD17.3.0.1.CC create mode 100755 Tests/Spec.Deviance/SPD17.3.0.2.CC create mode 100755 Tests/Spec.Deviance/SPD17.3.0.3.CC create mode 100755 Tests/Spec.Deviance/SPD17.5.0.1.CC create mode 100755 Tests/Spec.Deviance/SPD17.5.0.2.CC create mode 100755 Tests/Spec.Deviance/SPD17.6.0.1.CC create mode 100755 Tests/Spec.Deviance/SPD17.6.0.2.CC create mode 100755 Tests/Spec.Deviance/SPD17.6.0.3.CC create mode 100755 Tests/Spec.Deviance/SPD17.7.0.1.CC create mode 100755 Tests/Spec.Deviance/TEST create mode 100755 backup create mode 100755 cc.notes create mode 100755 count create mode 100755 linkit create mode 100755 linkit2 create mode 100755 make create mode 100755 make2 create mode 100644 obj/README.txt create mode 100755 smake diff --git a/Asm.pas b/Asm.pas new file mode 100755 index 0000000..c714070 --- /dev/null +++ b/Asm.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Asm } { } { This unit implements the built-in assembler and } { disassembler. } { } { External Subroutines: } { } { AsmFunction - assemble an assembly language function } { AsmStatement - assemble some in-line code } { InitAsm - initialize the assembler } { } {---------------------------------------------------------------} unit Asm; interface {$LibPrefix '0/obj/'} uses CCommon, Table, CGI, Scanner, Symbol, MM, Expression; {$segment 'cc'} procedure AsmFunction (variable: identPtr); { Assemble an assembly language function } { } { parameters: } { variable - pointer to the function variable } procedure AsmStatement; { Assemble some in-line code } procedure InitAsm; { Initialize the assembler } {---------------------------------------------------------------} implementation {---------------------------------------------------------------} var doingAsmFunction: boolean; {was AsmStatement called from AsmFunction?} {- Imported from the parser: -----------------------------------} procedure Match (kind: tokenEnum; err: integer); extern; { insure that the next token is of the specified type } { } { parameters: } { kind - expected token kind } { err - error number if the expected token is not found } {- Private routines --------------------------------------------} function FindLabel (name: stringPtr; definition: boolean): integer; { Find a label in the label list. If none exists, create one. } { } { parameters: } { name - name of the label } { definition - is this the defining point? } label 1; var lb: gotoPtr; {work pointer} lnum: integer; {label number} begin {FindLabel} lb := gotoList; {try to find an existing label} while lb <> nil do begin if lb^.name^ = name^ then begin lnum := lb^.lab; goto 1; end; lb := lb^.next; end; {while} lb := pointer(Malloc(sizeof(gotoRecord))); {no label record exists: create one} lb^.next := gotoList; gotoList := lb; lb^.name := name; lnum := GenLabel; lb^.lab := lnum; lb^.defined := false; 1: if definition then begin if lb^.defined then Error(77) else begin lb^.defined := true; Gen1(dc_lab, lb^.lab); end; {else} end; {if} FindLabel := lnum; end; {FindLabel} {- Global routines ---------------------------------------------} procedure AsmFunction {variable: identPtr}; { Assemble an assembly language function } { } { parameters: } { variable - pointer to the function variable } var tl: tempPtr; {work pointer} begin {AsmFunction} {process the statements} doingAsmFunction := true; AsmStatement; doingAsmFunction := false; {finish the subroutine} Gen0 (dc_enp); {finish the segment} CheckGotoList; {make sure all labels are declared} while tempList <> nil do begin {dump the local labels} tl := tempList; tempList := tl^.next; dispose(tl); end; {while} LInit; {dispose of the local memory pool} nameFound := false; {no pc_nam for the next function (yet)} doingFunction := false; {no longer doing a function} end; {AsmFunction} procedure AsmStatement; { Assemble some in-line code } label 1,2,3,99; var i: integer; {loop variable} lnum: integer; {label number} name: packed array[0..3] of char; {op code name} opc: opcode; {operation code enumeration} opname: tokenType; {operation code token} optype: operands; {operand type} {set by Exp} {----------} isConstant: boolean; {constant? (or identifier expression} operand: tokenType; {operand (if not isConstant)} operation: (plus,minus,none); {kind of operation} size: (directPage,absoluteaddress,longAddress); {size of the operand} value: longint; {expression value} procedure Skip; { An error was found: skip to the end & quit } begin {Skip} charKinds[ord('#')] := ch_pound; while not (token.kind in [rbracech,eofsy]) do NextToken; charKinds[ord('#')] := illegal; goto 99; end; {Skip} procedure Exp (stop: tokenSet; EOLallowed: boolean); { Parse an expression in an operand } { } { Parameters: } { stop - stop symbols } { EOLallowed - can the expression end with EOL? } { } { Outputs: } { isConstant - constant? (or identifier expression) } { operand - operand (if not isConstant) } { operation - kind of operation } { size - size of the operand } { value - expression value } var forced: boolean; {is the expression type forced?} i: 0..maxint; {loop/index variable} id: identPtr; {identifier} tcode: intermediate_code; {temp storage for code} begin {Exp} if token.kind in [ltch,barch,gtch] {allow for operand size forcing} then begin forced := true; if token.kind = ltch then size := directPage else if token.kind = barch then size := absoluteaddress else {if token.kind = gtch then} size := longAddress; NextToken; end {if} else forced := false; if EOLallowed then begin {handle expressions that can end at eol} reportEOL := true; stop := stop+[eolsy]; end; {if} if token.kind = ident then begin {handle expressions with an identifier} if not forced then size := absoluteaddress; isConstant := false; operand := token; id := FindSymbol(token, variableSpace, false, true); if id = nil then begin code^.llab := FindLabel(token.name, false); if (not forced) and (not smallMemoryModel) then size := longAddress; end {if} else begin operand.symbolPtr := id; if id^.storage in [stackFrame,parameter] then begin code^.slab := id^.lln; if not forced then size := directPage; end {if} else begin code^.lab := id^.name; if id^.itype^.kind = functionType then begin if id^.itype^.isPascal then begin code^.lab := pointer(Malloc(length(id^.name^)+1)); CopyString(pointer(code^.lab), pointer(id^.name)); for i := 1 to length(code^.lab^) do if code^.lab^[i] in ['a'..'z'] then code^.lab^[i] := chr(ord(code^.lab^[i]) & $5F); end; {if} end; {if} if (not forced) and (not smallMemoryModel) then size := longAddress; end; {else} end; {else} NextToken; if token.kind in [plusch,minusch] then begin if token.kind = plusch then operation := plus else operation := minus; NextToken; tcode := code^; Expression(arrayExpression, stop); code^ := tcode; value := expressionValue; if expressionType^.kind = scalarType then if expressionType^.baseType <= cgUWord then value := value & $0000FFFF; end {if} else begin operation := none; value := 0; end; {else} end {if token = ident} else begin {constant expression} operation := none; isConstant := true; tcode := code^; Expression(arrayExpression, stop); code^ := tcode; value := expressionValue; if expressionType^.kind = scalarType then if expressionType^.baseType <= cgUWord then value := value & $0000FFFF; if not forced then if long(value).msw = 0 then begin if long(value).lsw & $FF00 = 0 then size := directPage else size := absoluteaddress; end {if} else size := longAddress; end; {else} reportEOL := false; if token.kind = eolsy then NextToken; end; {Exp} function RegCompare (str: stringPtr; reg: char): boolean; { Compare a string to a register constant } { } { parameters: } { str - string pointer } { reg - register character } begin {RegCompare} RegCompare := false; if length(str^) = 1 then RegCompare := chr(ord(str^[1]) | $20) = reg; end; {RegCompare} procedure CheckForComment; { Handle an assembly language comment (ignore chars from ; to EOL) } begin {CheckForComment} while token.kind = semicolonch do begin while not (charKinds[ord(ch)] in [ch_eol,ch_eof]) do NextCh; NextCh; NextToken; end; {if} end; {CheckForComment} begin {AsmStatement} Match(lbracech,27); while not (token.kind in [rbracech,eofsy]) do begin {find the label and op-code} CheckForComment; charKinds[ord('#')] := ch_pound; {allow # as a token} if token.kind <> ident then begin {error if not an identifier} Error(9); Skip; end; {if} opname := token; NextToken; while token.kind = colonch do begin {define a label} lnum := FindLabel(opname.name, true); NextToken; CheckForComment; if token.kind <> ident then Skip; opname := token; NextToken; end; {while} charKinds[ord('#')] := illegal; {don't allow # as a token} {identify the op-code} if length(opname.name^) = 3 then begin name := opname.name^; for i := 1 to 3 do if name[i] in ['A'..'Z'] then name[i] := chr(ord(name[i]) | $20); for opc := o_adc to o_xce do if names[opc] = name then goto 1; end; {if} Error(95); Skip; 1: code^.q := 0; {default to no flags} {handle general operand instructions} if opc <= o_tsb then begin optype := op; if token.kind = lparench then begin NextToken; Exp([commach,rparench], false); if token.kind = commach then begin NextToken; if token.kind = ident then begin if RegCompare(token.name, 'x') then begin NextToken; Match(rparench,12); if size = directPage then optype := i_dp_x else if size = absoluteaddress then optype := i_op_x else Error(96); end {if} else if RegCompare(token.name, 's') then begin NextToken; Match(rparench,12); Match(commach,86); if token.kind = ident then begin if RegCompare(token.name, 'y') then NextToken else Error(97); end {if} else Error(97); if size = directPage then optype := i_dp_s_y else Error(96); end {else if} else Error(97); end {if token.kind = ident} else Error(97); end {if token.kind = commach} else if token.kind = rparench then begin NextToken; if token.kind = commach then begin NextToken; if token.kind = ident then begin if RegCompare(token.name, 'y') then NextToken else Error(97); end {if} else Error(97); if size = directPage then optype := i_dp_y else Error(96); end {if} else begin if size = directPage then optype := i_dp else if size = absoluteaddress then optype := i_op else Error(96); end; {else} end {else if token.kind = rparench} else Error(12); end {if} else if token.kind = lbrackch then begin NextToken; Exp([commach,rbrackch], false); Match(rbrackch,24); if token.kind = commach then begin NextToken; if token.kind = ident then begin if RegCompare(token.name, 'y') then NextToken else Error(97); end {if} else Error(97); if size = directPage then optype := li_dp_y else Error(96); end {if} else begin if size = directPage then optype := li_dp else if size = absoluteaddress then optype := i_la else Error(96); end; {else} end {else if} else if token.kind = poundch then begin optype := imm; NextToken; if token.kind = ltch then begin NextToken; Exp([semicolonch], true); end {if} else if token.kind = gtch then begin NextToken; Exp([semicolonch], true); if isConstant then value := value >> 8 else code^.q := shift8; end {else if} else if token.kind = carotch then begin NextToken; Exp([semicolonch], true); if isConstant then value := value >> 16 else code^.q := shift16; end {else if} else Exp([semicolonch], true); end {else if} else begin if token.kind = ident then if RegCompare(token.name, 'a') then begin optype := acc; NextToken; goto 2; end; {if} Exp([commach,semicolonch], true); if token.kind = commach then begin NextToken; if token.kind = ident then begin if RegCompare(token.name, 'x') then begin NextToken; if size = directPage then optype := dp_x else if size = absoluteaddress then optype := op_x else optype := long_x; end {if} else if RegCompare(token.name, 'y') then begin NextToken; if size = directPage then optype := dp_y else if size = absoluteaddress then optype := op_y else Error(96); end {else if} else if RegCompare(token.name, 's') then begin NextToken; if size = directPage then optype := dp_s else Error(96); end {else if} else Error(97); end {if token.kind = ident} else Error(97); end {if} else begin if size = directPage then optype := dp else if size = absoluteaddress then optype := op else optype := la; end; {else} end; {else} 2: {make sure the operand is valid} if nopcodes[opc,optype] = 0 then begin if optype = i_dp_x then optype := i_op_x else if optype = i_dp then optype := i_op else if optype = dp then optype := op else if optype = dp_x then optype := op_x else if optype = dp_y then optype := op_y; if nopcodes[opc,optype] = 0 then if optype = op then optype := la; if nopcodes[opc,optype] = 0 then Error(98); end; {if} code^.s := nopcodes[opc,optype]; if optype = acc then code^.r := ord(implied) else if optype = imm then code^.r := ord(imm) else if optype in [la,long_x] then code^.r := ord(longabsolute) else if optype in [op,op_x,op_y,i_op,i_op_x,i_la] then code^.r := ord(absolute) else code^.r := ord(direct); end {if opc <= o_tsb} {handle data declarations} else if opc <= o_dcl then begin Exp([semicolonch], true); code^.s := d_add; if opc = o_dcb then code^.r := ord(direct) else if opc = o_dcw then code^.r := ord(absolute) else code^.r := ord(longabsolute); end {if opc <= o_dcl} {handle the brk instruction} else if opc = o_brk then begin Exp([semicolonch], true); code^.r := ord(direct); code^.s := 0; end {if opc = o_brk} {handle moves} else if opc in [o_mvn,o_mvp] then begin if opc = o_mvn then code^.s := $54 else code^.s := $44; Gen0(pc_nat); code^.s := d_bmov; code^.r := ord(immediate); Exp([commach,semicolonch], false); if isConstant then begin code^.opnd := long(value).msw; code^.q := 0; end {if} else begin code^.opnd := value; code^.q := shift16; end; {else} Gen0(pc_nat); Match(commach,86); code^.s := d_bmov; code^.r := ord(immediate); Exp([semicolonch], true); if isConstant then begin code^.opnd := long(value).msw; code^.q := 0; end {if} else begin code^.opnd := value; code^.q := shift16; end; {else} goto 3; end {if opc in [o_mvn,o_mvp]} {handle relative branches} else if opc <= o_bvs then begin code^.s := ropcodes[opc]; if token.kind = ident then begin code^.llab := FindLabel(token.name, false); NextToken; code^.lab := nil; if opc in [o_brl,o_per] then code^.r := ord(longrelative) else code^.r := ord(relative); goto 3; end {if} else Error(97); end {else if opc <= o_bvs} {handle implied operand instructions} else begin code^.s := iopcodes[opc]; code^.r := ord(implied); end; {generate the code} if operation = minus then code^.opnd := -value else code^.opnd := value; 3: Gen0(pc_nat); CheckForComment; end; {while} 99: if doingAsmFunction then useGlobalPool := true; Match(rbracech,23); end; {AsmStatement} procedure InitAsm; { Initialize the assembler } begin {AsmInit} doingAsmFunction := false; end; {AsmInit} end. \ No newline at end of file diff --git a/CC.pas b/CC.pas new file mode 100755 index 0000000..6030074 --- /dev/null +++ b/CC.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ORCA/C } { } { A C compiler for the Apple IIGS. } { } { Copyright 1989,1990 } { Byte Works, Inc. } { } { Mike Westerfield } { } {---------------------------------------------------------------} {$stacksize $1800} program cc(output); {$LibPrefix '0/obj/'} uses CCommon, CGI, Scanner, Header, Symbol, MM, Expression, Parser, Asm; {$segment 'cc'} var i: 1..maxPath; {loop/index variable} vDCBGS: versionDCBGS; {for checking the version number} procedure DisposeAll (userID: integer); tool($02, $11); procedure SystemQuitFlags (flags: integer); extern; begin {cc} {make sure we quit with restart set} SystemQuitFlags($4000); {get the command line info} includeFileGS.maxSize := maxPath+4; includeFileGS.theString.size := 0; for i := 1 to maxPath do includeFileGS.theString.theString[i] := chr(0); outFileGS := includeFileGS; partialFileGS := includeFileGS; infoStringGS := includeFileGS; with liDCBGS do begin pCount := 11; sFile := @includeFileGS; dFile := @outFileGS; namesList := @partialFileGS; iString := @infoStringGS; end; {with} GetLInfoGS(liDCBGS); sourceFileGS := includeFileGS; doingPartial := partialFileGS.theString.size <> 0; with liDCBGS do begin enterEditor := pFlags & flag_e <> 0; {enter editor on terminal errors?} ignoreSymbols := mFlags & flag_i <> 0; {ignore symbol file?} list := pFlags & flag_l <> 0; {list the source file?} memoryCompile := pflags & flag_m <> 0; {memory based compile?} progress := mflags & flag_p = 0; {write progress info?} rebuildSymbols := mflags & flag_r <> 0; {rebuild symbol file?} printSymbols := pflags & flag_s <> 0; {print the symbol table?} terminalErrors := pFlags & flag_t <> 0; {all errors terminal?} wait := pFlags & flag_w <> 0; {wait when an error is found?} cLineOptimize := pFlags & flag_o <> 0; {turn optimizations on?} end; {liDCB} if list then {we don't need both...} progress := false; {check the version number} vDCBGS.pCount := 1; VersionGS(vDCBGS); if vDCBGS.version[1] < '2' then TermError(10); {write the header} if list or progress then begin writeln('ORCA/C ', versionStr); writeln; end; {if} {read the source file} ReadFile; languageNumber := long(ffDCBGS.auxType).lsw; {set the default language number} {initialize the various modules} LInit; {initialize the memory pools} GInit; useGlobalPool := true; InitCCommon; {initialize the common module} {initialize the scanner} InitScanner(bofPtr,pointer(ord4(bofPtr)+ffDCBGS.fileLength)); InitParser; {initialize the parser} InitExpression; {initialize the expression evaluator} InitSymbol; {initialize the symbol table handler} InitAsm; {initialize the assembler} CodeGenScalarInit; {initialize the code generator} with liDCBGS do {generate debug code?} if pFlags & flag_d <> 0 then begin debugFlag := true; profileFlag := true; end; {if} {compile the program} InitHeader(includeFileGS); {read any precompiled headers} NextToken; {get the first token in the program} while token.kind <> eofsy do begin {compile the program} if doingFunction then DoStatement else if (token.kind in [autosy,externsy,registersy,staticsy,typedefsy, unsignedsy,signedsy,intsy,longsy,charsy,shortsy, floatsy,doublesy,compsy,extendedsy,enumsy, structsy,unionsy,typedef,voidsy,volatilesy, constsy,ident,asmsy,pascalsy,asmsy,segmentsy]) then DoDeclaration(false) else begin Error(26); NextToken; end; {else} end; {while} if doingFunction then {check for unclosed function} Error(23); {init the code generator (if it needs it)} if not codegenStarted and (liDCBGS.kFlag <> 0) then begin CodeGenInit (@outFileGS, liDCBGS.kFlag, doingPartial); liDCBGS.kFlag := 3; codegenStarted := true; end; {if} DoGlobals; {create the ~GLOBALS and ~ARRAYS segments} {shut down the compiler} TermHeader; {make sure the compiled header file is closed} CheckStaticFunctions; {check for undefined functions} ffDCBGS.action := 7; {purge the source file} ffDCBGS.pcount := 14; ffDCBGS.pathName := @includeFileGS.theString; FastFileGS(ffDCBGS); if ToolError <> 0 then begin sourceFileGS := includeFileGS; TermError(2); end; {if} TermScanner; {shut down the scanner} StopSpin; if (numErrors <> 0) or list or progress then begin writeln; {write the number of errors} if numErrors = 1 then writeln('1 error found.') else writeln(numErrors:1, ' errors found.'); end; {if} if list or progress then {leave a blank line} writeln; if codegenStarted then {shut down the code generator} CodeGenFini; TermParser; {shut down the parser} if numErrors = 0 then begin {set up the return parameters} if not switchLanguages then begin if liDCBGS.kFlag = 0 then liDCBGS.lops := 0 else liDCBGS.lops := liDCBGS.lops & $FFFE; liDCBGS.sFile := @outFileGS; end; {if} end {if} else liDCBGS.lops := 0; MMQuit; {dispose of our memory pools} with liDCBGS do begin {return to the shell} sFile := pointer(ord4(sFile)+2); dFile := pointer(ord4(dFile)+2); namesList := pointer(ord4(namesList)+2); iString := pointer(ord4(iString)+2); end; {with} SetLInfoGS(liDCBGS); StopSpin; end. {cc} \ No newline at end of file diff --git a/CC.rez b/CC.rez new file mode 100755 index 0000000..bc9da2b --- /dev/null +++ b/CC.rez @@ -0,0 +1 @@ +#include "types.rez" resource rVersion(1) { { 2, /* Major revision */ 1, /* Minor revision */ 0, /* Bug version */ release, /* Release stage */ 0, /* Non-final release # */ }, verUS, /* Region code */ "ORCA/C", /* Short version number */ "Copyright 1996, Byte Works, Inc." /* Long version number */ }; \ No newline at end of file diff --git a/CC.rez2 b/CC.rez2 new file mode 100755 index 0000000..947b9bc --- /dev/null +++ b/CC.rez2 @@ -0,0 +1 @@ +#include "types.rez" resource rVersion(1) { { 2, /* Major revision */ 0, /* Minor revision */ 3, /* Bug version */ release, /* Release stage */ 0, /* Non-final release # */ }, verUS, /* Region code */ "ORCA/C (small memory)", /* Short version number */ "Copyright 1994, Byte Works, Inc." /* Long version number */ }; \ No newline at end of file diff --git a/CCommon.asm b/CCommon.asm new file mode 100755 index 0000000..8b311c6 --- /dev/null +++ b/CCommon.asm @@ -0,0 +1 @@ + mcopy ccommon.macros **************************************************************** * * CopyString - copy a string * * Inputs: * toPtr - location to copy to * fromPtr - location to copy from * **************************************************************** * CopyString start subroutine (4:toPtr,4:fromPtr),0 short I,M lda [fromPtr] sta [toPtr] tay lb1 lda [fromPtr],Y sta [toPtr],Y dey bne lb1 long I,M return end **************************************************************** * * Hash - find hash displacement * * Finds the displacement into an array of pointers using a * hash function. * * Inputs: * sPtr - points to string to find hash for * * Outputs: * Returns the disp into the hash table * **************************************************************** * Hash start hashSize equ 876 # hash buckets - 1 sum equ 0 hash length equ 2 length of string subroutine (4:sPtr),4 stz sum default to bucket 0 lda [sPtr] set the length of the string and #$00FF sta length ldy #1 start with char 1 lda [sPtr] if 1st char is '~', start with char 6 and #$FF00 cmp #'~'*256 bne lb1 ldy #6 lb1 lda [sPtr],Y get the value to add in and #$3F3F cpy length if there is only 1 char left then bne lb2 and #$00FF and out the high byte lb2 clc add it to the sum adc sum sta sum iny next char iny cpy length ble lb1 mod2 sum,#hashSize+1 return disp asl sum asl sum return 2:sum end \ No newline at end of file diff --git a/CCommon.macros b/CCommon.macros new file mode 100755 index 0000000..2b584a6 --- /dev/null +++ b/CCommon.macros @@ -0,0 +1 @@ + MACRO &lab subroutine &parms,&work &lab anop aif c:&work,.a lclc &work &work setc 0 .a gbla &totallen gbla &worklen &worklen seta &work &totallen seta 0 aif c:&parms=0,.e lclc &len lclc &p lcla &i &i seta c:&parms .b &p setc &parms(&i) &len amid &p,2,1 aif "&len"=":",.c &len amid &p,1,2 &p amid &p,4,l:&p-3 ago .d .c &len amid &p,1,1 &p amid &p,3,l:&p-2 .d &p equ &totallen+3+&work &totallen seta &totallen+&len &i seta &i-1 aif &i,^b .e tsc sec sbc #&work tcs inc a phd tcd mend MACRO &lab return &r &lab anop lclc &len aif c:&r,.a lclc &r &r setc 0 &len setc 0 ago .h .a &len amid &r,2,1 aif "&len"=":",.b &len amid &r,1,2 &r amid &r,4,l:&r-3 ago .c .b &len amid &r,1,1 &r amid &r,3,l:&r-2 .c aif &len<>2,.d ldy &r ago .h .d aif &len<>4,.e ldx &r+2 ldy &r ago .h .e aif &len<>10,.g aif &totallen=0,.f lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .f pld tsc clc adc #&worklen+&totallen tcs phb plx ply lda &r+8 pha lda &r+6 pha lda &r+4 pha lda &r+2 pha lda &r pha phy phx plb rtl mexit .g mnote 'Not a valid return length',16 mexit .h aif &totallen=0,.i lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .i pld tsc clc adc #&worklen+&totallen tcs aif &len=0,.j tya .j rtl mend MACRO &LAB MOD2 &N1,&N2,&N3 AIF C:&N3,.A LCLC &N3 &N3 SETC &N1 .A &LAB ~SETM LCLC &C &C AMID "&N2",1,1 AIF "{"="&C",.B AIF "["="&C",.B ~OP LDX,&N2 AGO .C .B ~LDA &N2 TAX .C ~LDA &N1 JSL ~MOD2 ~STA &N3 ~RESTM MEND MACRO &LAB ~SETM &LAB ANOP AIF C:&~LA,.B GBLB &~LA GBLB &~LI .B &~LA SETB S:LONGA &~LI SETB S:LONGI AIF S:LONGA.AND.S:LONGI,.A REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) LONGA ON LONGI ON .A MEND MACRO &LAB ~RESTM &LAB ANOP AIF (&~LA+&~LI)=2,.I SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) AIF &~LA,.H LONGA OFF .H AIF &~LI,.I LONGI OFF .I MEND MACRO &LAB ~LDA &OP LCLC &C &C AMID "&OP",1,1 AIF "&C"<>"{",.B &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B &LAB LDA &OP MEND MACRO &LAB ~STA &OP LCLC &C &C AMID "&OP",1,1 AIF "&C"<>"{",.B &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B &LAB STA &OP MEND MACRO &LAB ~OP &OPC,&OP LCLC &C &C AMID "&OP",1,1 AIF "&C"<>"{",.B &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B &LAB &OPC &OP MEND MACRO &LAB BLE &BP &LAB BLT &BP BEQ &BP MEND MACRO &LAB LONG &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB REP #&M*32+&I*16 AIF .NOT.&M,.B LONGA ON .B AIF .NOT.&I,.C LONGI ON .C MEND MACRO &LAB SHORT &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB SEP #&M*32+&I*16 AIF .NOT.&M,.B LONGA OFF .B AIF .NOT.&I,.C LONGI OFF .C MEND \ No newline at end of file diff --git a/CCommon.pas b/CCommon.pas new file mode 100755 index 0000000..1205dff --- /dev/null +++ b/CCommon.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { CCommon } { } { Common declarations and global data for the compiler. } { } { Variables: } { } { bofPtr - pointer to the start of sourceFile } { chPtr - pointer to the next character in the file } { codegenStarted - have we started the code generator? } { debugType - line number debug types } { doingFunction - true if processing a function } { doingParameters - are we processing parm definitions? } { doingPartial - are we doing a partial compile? } { enterEditor - enter editor on terminal errors? } { expandMacros - should macros be expanded? } { firstPtr - points to first char in current line } { gotoList - list of goto labels } { includeFile - include file name (for return from includes) } { infoString - language specific command line info } { lastLine - last line number used by pc_nam } { liDCB - get/set LInfo DCB } { lineNumber - source line number } { lint - lint flags } { list - generate source listing? } { memoryCompile - memory based compile? } { nameFound - has a pc_nam been generated? } { numErrors - number of errors in the program } { objFile - object file name } { oldincludeFile - previous includeFile value } { partialFile - partial compile list } { sourceFile - source file name } { terminalErrors - are all errors terminal? } { traceBack - generate traceback code? } { useGlobalPool - use global (or local) string pool? } { wait - wait for keypress after errors? } { } { doDispose - dispose of the expression tree as we go? } { expressionValue - the expression evaluator returns the } { value of constant expressions in this variable } { expressionType - the type of the expression } { expressionTree - for non-constant initializers } { isConstant - is the initializer expression conastant? } { } { External Subroutines: } { } { CheckGotoList - Make sure all labels have been defined } { ClearHourGlass - Erase the hourglass from the screen } { CopyLongString - copy a long string } { CopyString - copy a string } { DrawHourGlass - Draw the hourglass on the screen } { ExitToEditor - do an error exit to the editor } { GetLocalLabel - get the next local label number } { Hash - find hash displacement } { InitCCommon - Initialize this module } { ReadFile - read a file } { Spin - Spin the spinner } { StopSpin - Stop the spinner } { SystemError - intercept run time compiler errors } { TermError - flag a terminal error } { typeSpec - type of the last type specifier evaluated by } { TypeSpecifier } { } {---------------------------------------------------------------} unit CCommon; interface const {hashsize appears in CCOMMON.ASM} hashSize = 876; {# hash buckets - 1} hashSize2 = 1753; {# hash buckets * 2 - 1} maxLine = 255; {max length of a line} maxPath = 255; {max length of a path name} {NOTE: maxPath is used in Scanner.asm} longstringlen = 4000; {max length of a string constant} minChar = 0; {min ordinal value of source character} maxChar = 255; {max ordinal value of source character} {lint masks} {----------} lintUndefFn = $0001; {flag use of undefined functions} lintNoFnType = $0002; {flag functions with no type} lintNotPrototyped = $0004; {flag functions with no prototypes} lintPragmas = $0008; {flag unknown prototypes} {bit masks for GetLInfo flags} {----------------------------} flag_d = $10000000; {generate debug code?} flag_e = $08000000; {abort to editor on terminal error?} flag_i = $00800000; {ignore symbol files?} flag_l = $00100000; {list source lines?} flag_m = $00080000; {memory based compile?} flag_o = $00020000; {optimize?} flag_p = $00010000; {print progress info?} flag_r = $00004000; {rebuild symbol files?} flag_s = $00002000; {list symbol tables?} flag_t = $00001000; {treat all errors as terminal?} flag_w = $00000200; {wait when an error is found?} versionStr = '2.1.0'; {compiler version} type {Misc.} {-----} long = record lsw,msw: integer; end; {for extracting words from longints} cString = packed array [1..256] of char; {null terminated string} cStringPtr = ^cString; longString = record {long null terminated string} length: integer; str: packed array [1..longstringlen] of char; end; longStringPtr = ^longString; pString = packed array [0..maxLine] of char; {length string} stringPtr = ^pString; ptr = ^byte; {general purpose pointer} handle = ^ptr; {gereral purpose handle} gsosInString = record size: integer; theString: packed array [1..maxPath] of char; end; gsosInStringPtr = ^gsosInString; {GS/OS class 1 output string} gsosOutString = record maxSize: integer; theString: gsosInString; end; gsosOutStringPtr = ^gsosOutString; { The base types include two main categories. The values starting } { with cg are defined in the code generater, and may be passed to the } { code generator for resolution. The cc types are used internally in } { the compiler. Any values whose type is cc must be resulved to one } { of the cg types before the code generator is called. } baseTypeEnum = (cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong, cgReal,cgDouble,cgComp,cgExtended,cgString, cgVoid,ccPointer); {tokens} {------} {Note: tokenEnum is duplicated in } { Table.asm } tokenEnum = ( {enumeration of the tokens} ident, {identifiers} {constants} intconst,uintconst,longconst,ulongconst,doubleconst, stringconst, {reserved words} autosy,asmsy,breaksy,casesy,charsy, continuesy,constsy,compsy,defaultsy,dosy, doublesy,elsesy,enumsy,externsy,extendedsy, floatsy,forsy,gotosy,ifsy,intsy, inlinesy,longsy,pascalsy,registersy,returnsy, shortsy,sizeofsy,staticsy,structsy,switchsy, segmentsy,signedsy,typedefsy,unionsy,unsignedsy, voidsy,volatilesy,whilesy, {reserved symbols} excch,percentch,carotch,andch,asteriskch, minusch,plusch,eqch,tildech,barch, dotch,ltch,gtch,slashch,questionch, lparench,rparench,lbrackch,rbrackch,lbracech, rbracech,commach,semicolonch,colonch,poundch, minusgtop,plusplusop,minusminusop,ltltop,gtgtop, lteqop,gteqop,eqeqop,exceqop,andandop, barbarop,pluseqop,minuseqop,asteriskeqop,slasheqop, percenteqop,ltlteqop,gtgteqop,andeqop,caroteqop, bareqop,poundpoundop, eolsy,eofsy, {control characters} typedef, {user types} uminus,uand,uasterisk, {converted operations} parameteroper,castoper,opplusplus,opminusminus, macroParm); {macro language} {Note: this enumeration also } { appears in TABLE.ASM, } { SCANNER.asm } charEnum = {character kinds} (illegal,ch_special,ch_dash,ch_plus,ch_lt,ch_gt,ch_eq,ch_exc, ch_and,ch_bar,ch_dot,ch_white,ch_eol,ch_eof,ch_char,ch_string, ch_asterisk,ch_slash,ch_percent,ch_carot,ch_pound,letter,digit); tokenSet = set of tokenEnum; tokenClass = (reservedWord,reservedSymbol,identifier,intConstant,longConstant, doubleConstant,stringConstant,macroParameter); identPtr = ^identRecord; {^ to a symbol table entry} tokenType = record {a token} kind: tokenEnum; {kind of token} numString: stringPtr; {chars in number (macros only)} case class: tokenClass of {token info} reservedWord : (); reservedSymbol: (); identifier : (name: stringPtr; symbolPtr: identPtr); intConstant : (ival: integer); longConstant : (lval: longint); doubleConstant: (rval: double); stringConstant: (sval: longstringPtr; ispstring: boolean); macroParameter: (pnum: integer); end; {expressions} {-----------} expressionKind = ( {kinds of expressions} preprocessorExpression, {used by preprocessor commands} arrayExpression, {array subscripts, case labels, bit-field lengths, enum values} initializerExpression, {static variable initializers} autoInitializerExpression, {auto variable initializers} normalExpression); {for run-time evaluation} typePtr = ^typeRecord; tokenPtr = ^tokenRecord; tokenRecord = record {for operation, operand stacks} next: tokenPtr; {next token on the stack} left,middle,right: tokenPtr; {operand paths for operations} token: tokenType; {token at this node/leaf} case boolean of true : (id: identPtr;); {^symbol table entry for this operand} false: (castType: typePtr;); {cast type (for type casts only)} end; {goto label list} {---------------} gotoPtr = ^gotoRecord; gotoRecord = record {Note: if the size changes, see gotoSize} next: gotoPtr; name: stringPtr; lab: integer; defined: boolean; end; {symbol tables} {-------------} {classes of variables in the sym. tbl} spaceType = (tagSpace,variableSpace,allSpaces,fieldListSpace); parameterPtr = ^parameterRecord; {prototype parameter list} parameterRecord = record next: parameterPtr; parameter: identPtr; parameterType: typePtr; end; typeKind = (scalarType,arrayType,pointerType,functionType,enumType, enumConst,structType,unionType,definedType); typeRecord = record {type} size: longint; {size of the type in bytes} isConstant: boolean; {is the type a constant?} saveDisp: longint; {disp in symbol file} case kind: typeKind of {NOTE: aType,pType and fType must overlap} scalarType : (baseType: baseTypeEnum;); arrayType : (aType: typePtr; elements: longint; ); pointerType : (pType: typePtr;); functionType: (fType: typePtr; {return type} varargs, {are there a variable # of args?} prototyped: boolean; {is it prototyped?} overrideKR: boolean; {K&R overrides to prototypes?} parameterList: parameterPtr; {prototyped parameter list} isPascal: boolean; {pascal parameters?} toolNum: integer; {non-zero for tool functions} dispatcher: longint; {dispatch addr} ); enumConst : (eval: integer;); enumType : (); definedType : (dType: typePtr;); structType, unionType : (fieldList: identPtr; {field list} sName: stringPtr; {struct name; for forward refs} ); end; initializerPtr = ^initializerRecord; {initializers} initializerRecord = record next: initializerPtr; {next record in the chain} count: integer; {# of duplicate records} bitdisp: integer; {disp in byte (field lists only)} bitsize: integer; {width in bits; 0 for byte sizes} isStruct: boolean; {is this a struct initializer?} case isConstant: boolean of {is this a constant initializer?} false: (iTree: tokenPtr); true : ( case itype: baseTypeEnum of cgByte, cgUByte, cgWord, cgUWord, cgLong, cgULong : (iVal: longint); cgString : (sVal: longstringPtr); cgReal, cgDouble, cgComp, cgExtended: (rVal: double); cgVoid, ccPointer: ( pVal: longint; pPlus: boolean; case isName: boolean of true : (pName: stringPtr); false: (pStr : longstringPtr); ); ); end; storageType = (stackFrame,parameter,external,global,none,private); stateKind = (declared,defined,initialized); identRecord = record {identifier} next: identPtr; {next symbol in this hash bucket} saved: boolean; {has the symbol been saved (hashed) in the symbol file?} name: stringPtr; {symbol name} itype: typePtr; {symbol type} disp: longint; {disp past start of struct (field lists only)} bitDisp: integer; {disp in byte (field lists only)} {parameter number (K&R parms only)} bitsize: integer; {width in bits; 0 for byte sizes} state: stateKind; {state of the definition} iPtr: initializerPtr; {pointer to the first initializer} isForwardDeclared: boolean; {does this var use a forward declared type?} class: tokenEnum; {storage class} case storage: storageType of stackFrame: (lln: integer); {local label #} parameter: (pln: integer; {paramater label #} pdisp: integer; {disp of parameter} pnext: identPtr); {next parameter} external: (); global,private: (); none: (); end; {mini-assembler} {--------------} {opcodes} opcode = (o_adc,o_and,o_asl,o_bit,o_cmp,o_cop,o_cpx,o_cpy,o_dec,o_eor, o_inc,o_jml,o_jmp,o_jsl,o_jsr,o_lda,o_ldx,o_ldy,o_lsr,o_ora, o_pea,o_pei,o_rep,o_rol,o_ror,o_sbc,o_sep,o_sta,o_stx,o_sty, o_stz,o_trb,o_tsb, o_dcb,o_dcw,o_dcl, o_brk, o_mvn,o_mvp, o_bcc,o_bcs,o_beq,o_bmi,o_bne,o_bpl,o_bra,o_brl,o_per,o_bvc, o_bvs, o_clc,o_cld,o_cli,o_clv,o_dex,o_dey,o_inx,o_iny,o_nop,o_pha, o_phb,o_phd,o_phk,o_php,o_phx,o_phy,o_pla,o_plb,o_pld,o_plp, o_plx,o_ply,o_rti,o_rtl,o_rts,o_sec,o_sed,o_sei,o_stp,o_tax, o_tay,o_tcd,o_tcs,o_tdc,o_tsc,o_tsx,o_txa,o_txs,o_txy,o_tya, o_tyx,o_wai,o_xba,o_xce); {addressing modes} operands = (acc,imm,dp,dp_x,dp_y,op,op_x,op_y,i_dp_x,i_dp_y,dp_s,li_dp,la, i_dp,i_op,i_la,i_op_x,i_dp_s_y,li_dp_y,long_x); {work variables} {--------------} tempPtr = ^tempRecord; tempRecord = record last,next: tempPtr; {doubly linked list} labelNum: integer; {label number} size: integer; {size of the variable} end; {ORCA Shell and ProDOS} {---------------------} timeField = array[1..8] of byte; optionListRecord = record totalSize: integer; requiredSize: integer; fileSysID: integer; theData: packed array [1..100] of char; end; optionListPtr = ^optionListRecord; fastFileDCBGS = record pcount: integer; action: integer; index: integer; flags: integer; fileHandle: handle; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; createDate: timeField; modDate: timeField; option: optionListPtr; fileLength: longint; blocksUsed: longint; end; getLInfoDCBGS = record pcount: integer; sFile: gsosOutStringPtr; dFile: gsosOutStringPtr; namesList: gsosOutStringPtr; iString: gsosOutStringPtr; merr: byte; merrf: byte; lops: byte; kFlag: byte; mFlags: longint; pFlags: longint; org: longint; end; getPrefixOSDCB = record pcount: integer; prefixNum: integer; prefix: gsosOutStringPtr; end; versionDCBGS = record pcount: integer; version: packed array[1..4] of char; end; {---------------------------------------------------------------} var {misc} {----} bofPtr: ptr; {pointer to the start of sourceFile} chPtr: ptr; {pointer to the next character in the file} {debugType is also in SCANNER.ASM} debugType: (stop,break,autogo); {line number debug types} doingParameters: boolean; {are we processing parm definitions?} expandMacros: boolean; {should macros be expanded?} ffDCBGS: fastFileDCBGS; {fast file DCB} firstPtr: ptr; {points to first char in current line} gotoList: gotoPtr; {list of goto labels} includeFileGS: gsosOutString; {include file name (for return from includes)} infoStringGS: gsosOutString; {language specific command line info} intLabel: integer; {last used label number} languageNumber: integer; {our language number} lastLine: 0..maxint; {last line number used by pc_nam} liDCBGS: getLInfoDCBGS; {get/set LInfo DCB} lineNumber: 0..maxint; {source line number} nameFound: boolean; {has a pc_nam been generated?} nextLocalLabel: integer; {next available local data label number} numErrors: integer; {number of errors in the program} objFile: gsosOutString; {object file name} oldincludeFileGS: gsosOutString; {previous includeFile value} outFileGS: gsosOutString; {keep file name} partialFileGS: gsosOutString; {partial compile list} sourceFileGS: gsosOutString; {debug source file name} tempList: tempPtr; {list of temp work variables} {expression results} {------------------} doDispose: boolean; {dispose of the expression tree as we go?} realExpressionValue: double; {value of the last real constant expression} expressionValue: longint; {value of the last constant expression} expressionType: typePtr; {the type of the expression} initializerTree: tokenPtr; {for non-constant initializers} isConstant: boolean; {is the initializer expression conastant?} {type specifier results} {----------------------} typeSpec: typePtr; {type specifier} {flags} {-----} codegenStarted: boolean; {have we started the code generator?} doingFunction: boolean; {are we processing a function?} doingPartial: boolean; {are we doing a partial compile?} enterEditor: boolean; {enter editor on terminal errors?} foundFunction: boolean; {has a function been found?} lint: integer; {lint flags} list: boolean; {generate source listing?} ignoreSymbols: boolean; {ignore .sym file?} memoryCompile: boolean; {memory based compile?} printSymbols: boolean; {+s flag set?} progress: boolean; {write progress info?} rebuildSymbols: boolean; {rebuild .sym file?} switchLanguages: boolean; {switch languages on exit?} terminalErrors: boolean; {are all errors terminal?} traceBack: boolean; {generate traceback code?} unix_1: boolean; {is int 32 bits? (or 16 bits)} useGlobalPool: boolean; {use global (or local) string pool?} wait: boolean; {wait for keypress after errors?} {---------------------------------------------------------------} {ORCA Shell and ProDOS} {---------------------} procedure GetLInfoGS (var parms: getLInfoDCBGS); prodos ($0141); procedure FastFileGS (var parms: fastFileDCBGS); prodos ($014E); procedure SetLInfoGS (var parms: getLInfoDCBGS); prodos ($0142); procedure GetPrefixGS (var parms: getPrefixOSDCB); prodos ($200A); procedure VersionGS (var parms: versionDCBGS); prodos ($0147); {---------------------------------------------------------------} procedure CheckGotoList; { Make sure all labels have been defined } procedure ClearHourGlass; { Erase the hourglass from the screen } procedure CopyLongString (toPtr, fromPtr: longStringptr); { copy a long string } { } { parameters: } { toPtr - location to copy to } { fromPtr - location to copy from } procedure CopyString (toPtr, fromPtr: ptr); extern; { copy a string } { } { parameters: } { toPtr - location to copy to } { fromPtr - location to copy from } procedure DrawHourGlass; { Draw the hourglass on the screen } procedure ExitToEditor (msg: stringPtr; disp: longint); { do an error exit to the editor } { } { parameters: } { msg - pointer to the error message } { disp - displacement into the error file } { } { variables: } { includeFile - source file name } function GenLabel: integer; { generate the next local label, checking for too many } function GetLocalLabel: integer; { get the next local label number } function Hash (sPtr: stringPtr): integer; extern; { find hash displacement } { } { Finds the displacement into an array of pointers using a } { hash function. } { } { parameters: } { sPtr - points to string to find hash for } procedure InitCCommon; { Initialize this module } procedure ReadFile; { read a file } { } { variables: } { bofPtr - pointer to the start of the file } { ffDCB.file_length - length of the file } { includeFile - source file name } procedure Spin; { Spin the spinner } { } { Notes: Starts the spinner if it is not already in use } procedure StopSpin; { Stop the spinner } { } { Notes: The call is safe, and ignored, if the spinner is } procedure SystemError (errNo: integer); { intercept run time compiler errors } procedure TermError (errnum: integer); { flag a terminal error } {---------------------------------------------------------------} implementation const {Note: maxLabel is also defined in cgi.pas} maxLabel = 2400; {max # compiler generated labels} {spinner} {-------} spinSpeed = 8; {calls before one spinner move} type consoleOutDCBGS = record pcount: integer; ch: char; end; var {spinner} {-------} spinning: boolean; {are we spinning now?} spinDisp: integer; {disp to the spinner character} spinCount: integer; {spin loop counter} spinner: array[0..3] of char; {spinner characters} procedure Error (err: integer); extern; {in scanner.pas} { flag an error } { } { err - error number } {procedure Error2 (loc, err: integer); extern; {debug} {in scanner.pas} { flag an error } { } { loc - error location } { err - error number } procedure MMQuit; extern; {in mm.pas} { Dispose of memory allocated with private user IDs } procedure ConsoleOutGS (var parms: consoleOutDCBGS); prodos ($015A); {---------------------------------------------------------------} procedure CheckGotoList; { Make sure all labels have been defined } var gt: gotoPtr; {work pointer} msg: stringPtr; {work string} begin {CheckGotoList} gt := gotoList; while gt <> nil do begin if not gt^.defined then begin numErrors := numErrors+1; new(msg); msg^ := concat('Undefined label: ', gt^.name^); writeln(msg^); if terminalErrors then begin if enterEditor then ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr)) else TermError(0); end; {if} dispose(msg); end; {if} gt := gt^.next; end; {while} end; {CheckGotoList} procedure ClearHourGlass; { Erase the hourglass from the screen } var coRec: consoleOutDCBGS; {Console out record} begin {ClearHourGlass} coRec.pcount := 1; coRec.ch := ' '; ConsoleOutGS(coRec); coRec.ch := chr(8); ConsoleOutGS(coRec); end; {ClearHourGlass} procedure CopyLongString {toPtr, fromPtr: longStringPtr}; { copy a long string } { } { parameters: } { toPtr - location to copy to } { fromPtr - location to copy from } var i: integer; {loop variable} begin {CopyLongString} toPtr^.length := fromPtr^.length; {set the length} for i := 1 to fromPtr^.length do toPtr^.str[i] := fromPtr^.str[i]; end; {CopyLongString} procedure DrawHourGlass; { Draw the hourglass on the screen } var coRec: consoleOutDCBGS; {Console out record} begin {DrawHourGlass} coRec.pcount := 1; coRec.ch := chr(27); ConsoleOutGS(coRec); coRec.ch := chr(15); ConsoleOutGS(coRec); coRec.ch := 'C'; ConsoleOutGS(coRec); coRec.ch := chr(24); ConsoleOutGS(coRec); coRec.ch := chr(14); ConsoleOutGS(coRec); coRec.ch := chr(8); ConsoleOutGS(coRec); end; {DrawHourGlass} procedure ExitToEditor {msg: stringPtr; disp: longint}; { do an error exit to the editor } { } { parameters: } { msg - pointer to the error message } { disp - displacement into the error file } { } { variables: } { includeFile - source file name } var msgGS: gsosInString; {message} begin {ExitToEditor} msgGS.size := length(msg^); {set up the error message} msgGS.theString := msg^; liDCBGS.org := disp; {mark the error} liDCBGS.namesList := @msgGS; liDCBGS.lops := 0; {prevent re-entry} liDCBGS.merrf := 255; with liDCBGS do begin sFile := pointer(ord4(sFile)+2); dFile := pointer(ord4(dFile)+2); iString := pointer(ord4(iString)+2); end; {with} SetLInfoGS(liDCBGS); StopSpin; {stop the spinner} MMQuit; {dispose of the memory pools} halt(-1); {return to the shell} end; {ExitToEditor} function GenLabel{: integer}; { generate the next local label, checking for too many } begin {GenLabel} if intLabel < maxLabel then intLabel := intLabel+1 else begin intLabel := 0; Error(58); end; GenLabel := intLabel; end; {GenLabel} function GetLocalLabel{: integer}; { get the next local label number } begin {GetLocalLabel} GetLocalLabel := nextLocalLabel; nextLocalLabel := nextLocalLabel+1; end; {GetLocalLabel} procedure InitCCommon; { Initialize this module } begin {InitCCommon} spinning := false; {not spinning the spinner} spinDisp := 0; {start spinning with the first character} spinner[0] := '|'; {set up the spinner characters} spinner[1] := '/'; spinner[2] := '-'; spinner[3] := '\'; end; {InitCCommon} procedure ReadFile; { read a file } { } { variables: } { bofPtr - pointer to the start of the file } { ffDCB.file_length - length of the file } { includeFile - source file name } const SRC = $B0; {source file type} begin {ReadFile} with ffDCBGS do begin {read the source file} pCount := 14; action := 0; flags := $C000; pathName := @includeFileGS.theString; end; {with} FastFileGS(ffDCBGS); if ToolError <> 0 then begin sourceFileGS := includeFileGS; includeFileGS := oldincludeFileGS; TermError(1); end; {if} if ffDCBGS.fileType <> SRC then begin includeFileGS := oldincludeFileGS; TermError(6); end; {if} bofPtr := ffDCBGS.fileHandle^; {set beginning of file pointer} end; {ReadFile} procedure Spin; { Spin the spinner } { } { Notes: Starts the spinner if it is not already in use } var coRec: consoleOutDCBGS; {Console out record} begin {Spin} if not spinning then begin spinning := true; spinCount := spinSpeed; end; {if} spinCount := spinCount - 1; if spinCount = 0 then begin spinCount := spinSpeed; spinDisp := spinDisp - 1; if spinDisp < 0 then spinDisp := 3; coRec.pcount := 1; coRec.ch := spinner[spinDisp]; ConsoleOutGS(coRec); coRec.ch := chr(8); ConsoleOutGS(coRec); end; {if} end; {Spin} procedure StopSpin; { Stop the spinner } { } { Notes: The call is safe, and ignored, if the spinner is } { inactive. } var coRec: consoleOutDCBGS; {Console out record} begin {StopSpin} if spinning then begin spinning := false; coRec.pcount := 1; coRec.ch := ' '; ConsoleOutGS(coRec); coRec.ch := chr(8); ConsoleOutGS(coRec); end; {if} end; {StopSpin} procedure SystemError {errNo: integer}; { intercept run time compiler errors } begin {SystemError} if errNo = 5 then TermError(5) else TermError(3); end; {SystemError} procedure TermError {errnum: integer}; { flag a terminal error } var msg: pString; {terminal error message} begin {TermError} case errnum of {print the error} 0 : ; 1 : msg := concat('Error reading ', sourceFileGS.theString.theString); 2 : msg := concat('Error purging ', sourceFileGS.theString.theString); 3 : msg := 'terminal compiler error'; 4 : msg := 'user termination'; 5 : msg := 'out of memory'; 6 : msg := 'source files must have a file type of SRC'; 7 : msg := 'you cannot change languages with an include directive'; 8 : msg := 'you cannot change languages from an included file'; 9 : msg := concat('Error writing ', objFile.theString.theString); 10: msg := 'ORCA/C requires version 2.0 or later of the shell'; 11: msg := 'The program is too large to compile to memory -- use Compile to Disk'; otherwise: Error(57); end; {case} with ffDCBGS do begin {purge the source file} pCount := 5; action := 7; pathName := @includeFileGS.theString; end; {with} FastFileGS(ffDCBGS); writeln('Terminal error: ', msg); {write the error to stdout} if enterEditor then {error exit to editor} ExitToEditor(@msg, ord4(chPtr) - ord4(bofPtr)) else begin liDCBGS.lops := 0; {prevent re-entry} liDCBGS.merrf := 127; with liDCBGS do begin sFile := pointer(ord4(sFile)+2); dFile := pointer(ord4(dFile)+2); namesList := pointer(ord4(namesList)+2); iString := pointer(ord4(iString)+2); end; {with} SetLInfoGS(liDCBGS); StopSpin; {stop the spinner} MMQuit; {dispose of the memory pools} halt(-1); {return to the shell} end; {else} end; {TermError} end. {$append 'ccommon.asm'} \ No newline at end of file diff --git a/CGC.asm b/CGC.asm new file mode 100755 index 0000000..7e5043f --- /dev/null +++ b/CGC.asm @@ -0,0 +1 @@ + mcopy cgc.macros **************************************************************** * * CnvSX - Convert floating point to SANE extended * * Inputs: * rec - pointer to a record * **************************************************************** * CnvSX start rec equ 4 record containing values rec_real equ 0 disp to real value rec_ext equ 8 disp to extended (SANE) value tsc set up DP phd tcd ph4 rec push addr of real number clc push addr of SANE number lda rec adc #rec_ext tax lda rec+2 adc #0 pha phx fd2x convert TOS to extended move4 0,4 return pld pla pla rtl end **************************************************************** * * CnvSC - Convert floating point to SANE comp * * Inputs: * rec - pointer to a record * **************************************************************** * CnvSC start rec equ 4 record containing values rec_real equ 0 disp to real value rec_ext equ 8 disp to extended (SANE) value rec_cmp equ 18 disp to comp (SANE) value tsc set up DP phd tcd ph4 rec push addr of real number clc push addr of SANE number lda rec adc #rec_ext tax lda rec+2 adc #0 pha phx fd2x convert TOS to extended clc push addr of SANE number lda rec adc #rec_ext tax lda rec+2 adc #0 pha phx clc push addr of COMP number lda rec adc #rec_cmp tax lda rec+2 adc #0 pha phx fx2c convert TOS to extended move4 0,4 return pld pla pla rtl end **************************************************************** * * InitLabels - initialize the labels array * * Outputs: * labelTab - initialized * intLabel - initialized * **************************************************************** * InitLabels start maxLabel equ 2400 ! with labelTab[0] do begin lda #-1 val := -1; sta labelTab+6 sta labelTab+8 stz labelTab defined := false; stz labelTab+2 chain := nil; stz labelTab+4 ! end; {with} ldx #labelTab for i := 1 to maxLabel do ldy #labelTab+10 labelTab[i] := labelTab[0]; lda #maxLabel*10-1 mvn labelTab,labelTab stz intLabel intLabel := 0; rtl end \ No newline at end of file diff --git a/CGC.macros b/CGC.macros new file mode 100755 index 0000000..cf7e582 --- /dev/null +++ b/CGC.macros @@ -0,0 +1 @@ + macro &l move4 &m1,&m2 lclb &yistwo &l ~setm ~lda &m1 ~sta &m2 ~lda.h &m1 ~sta.h &m2 ~restm mend macro &l ph4 &n1 aif "&n1"="*",.f lclc &c &l anop &c amid &n1,1,1 aif "&c"="#",.d aif s:longa=1,.a rep #%00100000 .a aif "&c"<>"{",.b &c amid &n1,l:&n1,1 aif "&c"<>"}",.g &n1 amid &n1,2,l:&n1-2 ldy #2 lda (&n1),y pha lda (&n1) pha ago .e .b aif "&c"<>"[",.c ldy #2 lda &n1,y pha lda &n1 pha ago .e .c aif "&c"<>"<",.c1 &n1 amid &n1,2,l:&n1-1 pei &n1+2 pei &n1 ago .e .c1 lda &n1+2 pha lda &n1 pha ago .e .d &n1 amid &n1,2,l:&n1-1 pea +(&n1)|-16 pea &n1 ago .f .e aif s:longa=1,.f sep #%00100000 .f mexit .g mnote "Missing closing '}'",16 mend macro &l ~lda &op lclc &c &c amid "&op",1,1 aif "&c"<>"{",.b &c amid "&op",l:&op,1 aif "&c"="}",.a mnote "Missing closing '}'",2 &op setc &op} .a &op amid "&op",2,l:&op-2 &op setc (&op) .b &l lda &op mend macro &l ~lda.h &op &l anop lclc &c &c amid "&op",1,1 aif "&c"="[",.b aif "&c"<>"{",.d &c amid "&op",l:&op,1 aif "&c"="}",.a mnote "Missing closing '}'",2 &op setc &op} .a &op amid "&op",2,l:&op-2 &op setc (&op) .b aif &yistwo,.c &yistwo setb 1 ldy #2 .c &op setc "&op,y" lda &op mexit .d aif "&c"<>"#",.e &op amid "&op",2,l:&op-1 &op setc "#^&op" lda &op mexit .e lda 2+&op mend macro &l ~restm &l anop aif (&~la+&~li)=2,.i sep #32*(.not.&~la)+16*(.not.&~li) aif &~la,.h longa off .h aif &~li,.i longi off .i mend macro &l ~setm &l anop aif c:&~la,.b gblb &~la gblb &~li .b &~la setb s:longa &~li setb s:longi aif s:longa.and.s:longi,.a rep #32*(.not.&~la)+16*(.not.&~li) longa on longi on .a mend macro &l ~sta &op lclc &c &c amid "&op",1,1 aif "&c"<>"{",.b &c amid "&op",l:&op,1 aif "&c"="}",.a mnote "Missing closing '}'",2 &op setc &op} .a &op amid "&op",2,l:&op-2 &op setc (&op) .b &l sta &op mend macro &l ~sta.h &op &l anop lclc &c &c amid "&op",1,1 aif "&c"="[",.b aif "&c"<>"{",.d &c amid "&op",l:&op,1 aif "&c"="}",.a mnote "Missing closing '}'",2 &op setc &op} .a &op amid "&op",2,l:&op-2 &op setc (&op) .b aif &yistwo,.c &yistwo setb 1 ldy #2 .c &op setc "&op,y" sta &op mexit .d sta 2+&op mend MACRO &LAB FD2X &LAB PEA $010E LDX #$090A JSL $E10000 MEND MACRO &LAB FX2C &LAB PEA $0510 LDX #$090A JSL $E10000 MEND \ No newline at end of file diff --git a/CGC.pas b/CGC.pas new file mode 100755 index 0000000..2428523 --- /dev/null +++ b/CGC.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ORCA Code Generator Common } { } { This unit contains the command constants, types, } { variables and procedures used throughout the code } { generator, but which are not available to the compiler. } { } {---------------------------------------------------------------} { } { These routines are defined in the compiler, but used from } { the code generator. } { } { Error - flag an error } { CMalloc - Clear and allocate memory from a pool. } { Malloc - Allocate memory from a pool. } { } {---------------------------------------------------------------} unit CGC; interface {$LibPrefix '0/obj/'} uses CCommon, CGI; {$segment 'cg'} type {pcode code generation} {---------------------} realrec = record {used to convert from real to in-SANE} itsReal: double; inSANE: packed array[1..10] of byte; inCOMP: packed array[1..8] of byte; end; var {msc} {---} blkcnt: integer; {number of bytes in current segment} {buffers} {-------} cbufflen: 0..maxcbuff; {number of bytes now in cbuff} segDisp: integer; {disp in the current segment} {-- Global subroutines -----------------------------------------} procedure CnvSC (rec: realrec); extern; { convert a real number to SANE comp format } { } { parameters: } { rec - record containing the value to convert; also } { has space for the result } procedure CnvSX (rec: realrec); extern; { convert a real number to SANE extended format } { } { parameters: } { rec - record containing the value to convert; also } { has space for the result } procedure InitLabels; extern; { initialize the labels array for a procedure } { } { Note: also defined in CGI.pas } {-- These routines are defined in the compiler, but used from cg --} function Calloc (bytes: integer): ptr; extern; { Allocate memory from a pool and clear it. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } procedure Error (err: integer); extern; { flag an error } { } { err - error number } {procedure Error2 (loc, err: integer); extern; {debug} {in scanner.pas} { flag an error } { } { loc - error location } { err - error number } function Malloc (bytes: integer): ptr; extern; { Allocate memory from a pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } {---------------------------------------------------------------} implementation end. {$append 'CGC.asm'} \ No newline at end of file diff --git a/CGI.Comments b/CGI.Comments new file mode 100755 index 0000000..44272e3 --- /dev/null +++ b/CGI.Comments @@ -0,0 +1 @@ +{-- Misc. pcodes -----------------------------------------------} { } { dc_cns - generate a constant value } { } { GenL1(dc_cns, lval, count); } { GenR1t(dc_cns, rval, count, type); } { Gen2t(dc_cns, ival, count, type); } { GenS(dc_cns, sptr); } { } { Creates COUNT occurrances of the constant lval, rval or } { ival, based on the type. In Gen2t can accept byte or word } { types. In the case of GenS, the operand is a string } { constant, and no repeat count is allowed. } { } { } { dc_glb - generate global label } { } { Gen2Name(dc_glb, r, q, lab) } { } { Creates a global label in the current segment with the name } { LAB^. If Q is 1, the label is marked as private to the } { current segment, otherwise it is marked as public. R bytes } { of space are reserved. } { } { } { dc_dst - generate global storage } { } { Gen1(dc_dst, q) } { } { Creates q bytes of storage (initialized to 0) at the } { current location. } { } { } { pc_lnm - line number } { } { Gen2(pc_lnm, lc, flag) } { } { Sets the current line number for the traceback facility and } { debugger. This p-code should only be generated after the } { pc_ent and pc_nam (if any), and should not be generated } { outside of a subroutine. Lc is the line number, while flag } { indicates the type of debugging action on this line: } { } { 0 - step/trace } { 1 - break point } { 2 - auto-go } { } { } { pc_mov - move memory } { } { Gen2(pc_mov, banks, bytes) } { } { The top of stack contains a source address, and TOS-1 has a } { destination address. The destination address is removed, } { and BYTES bytes are moved from the source to the } { destination. BANKS is the number of full banks to move; it } { is used when 64K or more must be moved. The memory areas } { must not overlap. } { } { } { pc_nam - subroutine name } { } { GenS(pc_nam, str) } { } { Sets the subroutine name for the traceback facility, } { debugger, and profiler. Str is a pointer to the subroutine } { name. The following global variables should be set to } { appropriate values when this p-code is used: } { } { debugFlag - are we generating debug code? } { profileFlag - are we profiling? } { traceBack - are we doing tracebacks? } { sourceFile - current source file name } { } { } { pc_nat - native code generation } { } { Gen0(pc_nat) } { } { Generate a native code instruction. The parameters are set } { in a special section in asm.pas. } { } { s - operation code } { q - operand value } { r - addressing mode } { lab - label name } { flags - shift flags } { } {-- Pcodes involved expressions --------------------------------} { } { pc_adi - integer addition } { pc_adl - long addition } { pc_adr - real addition } { } { Gen0(pc_adi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_adl) cgLong,cgULong } { Gen0(pc_adr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } { removed and added. The result is placed back on the stack. } { } { } { pc_and - logical and } { pc_lnd - long logical and } { } { Gen0(pc_and) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_lnd) cgLong,cgULong } { } { The two values on the top of the evaluation stack are } { removed and anded. The result is placed back on the stack. } { Zero is treated as false, and any other value as true. The } { and is a logical and. See pc_bnd for a bitwise and. } { } { If the first operand is false, the second operand is not } { evaluated. } { } { } { pc_bnd - bitwise and } { pc_bal - long bitwise and } { } { Gen0(pc_bnd) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_bal) cgLong,cgULong } { } { The two values on the top of the evaluation stack are } { removed and anded. The result is placed back on the stack. } { } { } { pc_bno - binary operand no-operation } { } { Gen0t(pc_bno, type) } { } { The left operand is evaluated and discarded, followed by } { the evaluation of the right operand. The type is the type } { of the right operand; it is used in case a pc_pop is } { attached to remove a result left on the stack. This } { instruction is used by C for the comma operator and for } { parameter lists for function and procedure calls, and by } { pc_tri to hold the two expressions. } { } { } { pc_bnt - bitwise negation } { pc_bnl - long bitwise negation } { } { Gen0(pc_bnt) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_bnl) cgLong,cgULong } { } { The value on the top of the evaluation stack is removed, } { exclusive ored with $FFFF, and replaced. (One's compliment.)} { } { } { pc_bor - bitwise or } { pc_blr - long bitwise or } { } { Gen0(pc_bor) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_blr) cgLong,cgULong } { } { The two values on the top of the evaluation stack are } { removed and ored. The result is placed back on the stack. } { } { } { pc_bxr - exclusive or } { pc_blx - long exclusive or } { } { Gen0(pc_bxr) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_blx) cgLong,cgULong } { } { The two values on the top of the evaluation stack are } { removed and exclusive ored. The result is placed back on } { the stack. } { } { } { pc_cbf - copy bit field } { } { Gen2t(pc_cbf, disp, size, type) } { } { An integer is removed from the top of the evaluation stack } { and saved at the address on the evaluation stack. The } { address is removed, but the integer remains intact. The } { value is saved DISP bits past the address, and is treated as } { a SIZE bit value. Extra bits are dropped. } { } { } { pc_cop - copy to a local variable } { } { Gen2t(pc_cop, label, disp, type) } { } { Saves the value on the top of the evaluation stack to DISP } { bytes past the local label LABEL. TYPE is the type of the } { value being saved. } { } { } { pc_cnv - convert from one scalar type to another } { pc_cnn - convert from one scalar type to another } { } { Gen2(pc_cnv, from, to) } { Gen2(pc_cnn, from, to) } { } { Converts from one scalar type to another. The from and to } { parameters are ordinal values of type baseTypeEnum. The } { table below shows what from values (along the left edge) and } { to values (along the top) are allowed, and what action is } { taken for each combination. CgDouble, cgComp or cgExtended } { may be used anywhere that cgReal is used, with the same } { results. } { } { The pc_cnn form converts the value at tos-1. The value at } { tos is assumed to be the same size as the result type. } { } { cgByte cgUByte cgWord cgUWord cgLong cgULong cgReal } { cgByte extend extend float } { cgUByte padd padd float } { cgWord extend extend float } { cgUWord extend extend float } { cgLong discard discard discard discard float } { cgULong discard discard discard discard float } { cgReal trunc trunc trunc trunc trunc trunc } { } { The meaning of the operationd shown in the table is: } { } { (blank) No action is taken, but the instruction is } { accepted by the code generator. } { extend The value is sign extended to the proper length.} { padd The value is padded on the left with zero bits } { to extend it to the proper length. } { discard Extra bits are discarded to reach the proper } { length, starting with the most significant bit. } { float An integer value is converted to a real value. } { trunc A real value is converted to the largest } { integer value that is less than or equal to the } { real value. } { } { } { pc_cpi - copy indirect } { } { Gen0t(pc_cpi, type) } { } { Two values are removed from the evaluation stack. The first } { is of type TYPE, while the second is a pointer. The first } { value is stored at the location pointed to by the pointer. } { The value is then placed back on the stack. } { } { } { pc_cpo - copy to a global variable } { } { Gen1tName (pc_cpo, disp, type, name) } { } { Saves the value on the top of the evaluation stack to the } { global label NAME. DISP is a fixed displacement past the } { names label to load from. (Used for records.) TYPE is } { the type of the value being loaded. } { } { } { pc_dec - decrement } { } { Gen1t(pc_dec, val, type) } { } { The value on the top of the stack is removed, decremented by } { VAL and returned to the stack. Type may be cgByte, cgUByte, } { cgWord, cgUWord, cgLong or cgULong. In all cases, the } { amount to decrement by is a positive signed integer. } { } { } { pc_dvi - integer divide } { pc_udi - unsigned integer divide } { pc_dvl - long integer divide } { pc_udl - unsigned long divide } { pc_dvr - real divide } { } { Gen0(pc_dvi) cgByte,cgWord } { Gen0(pc_udi) cgUByte,cgUWord } { Gen0(pc_dvl) cgLong } { Gen0(pc_udl) cgULong } { Gen0(pc_dvr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } { removed and divided. The result is placed back on the } { stack. The result type is the same as the argument type. } { } { } { pc_equ,pc_geq,pc_grt,pc_leq,pc_les,pc_neq - compares } { } { Gen0t(pc_equ, type) } { } { The two values on the top of the evaluation stack are } { removed and compared. A boolean result is placed back on } { the stack. } { } { } { pc_gil - increment and load from a global variable } { pc_gli - load a global variable, then inc the original } { pc_gdl - decrement and load from a global variable } { pc_gld - load a global variable, then dec the original } { } { Gen2tName (pc_gli, inc, disp, type, name) } { } { Loads a value from the global label NAME and places it on } { the evaluation stack. DISP is a fixed displacement past the } { names label to load from. (Used for records.) TYPE is } { the type of the value being loaded. } { } { In addition to loading the value, these instructions also } { increment or decrement the value, as indicated in the } { comment by the instruction name. The operand is incremented } { or decremented by INC. INC must be 1 for one and two byte } { operands. } { } { } { pc_iil - increment and load indirect } { pc_ili - load indirect, then inc the original } { pc_idl - decrement and load indirect } { pc_ild - load indirect, then dec the original } { } { Gen0t (pc_ili, type) } { } { Loads a value from the indirect address on the top of the } { stack, performing either an increment or decrement in the } { process. TYPE may be cgByte, cgUByte, cgWord or cgUWord. } { } { } { pc_inc - increment } { } { Gen1t(pc_inc, val, type) } { } { The value on the top of the stack is removed, incremented by } { VAL and returned to the stack. Type may be cgByte, cgUByte, } { cgWord, cgUWord, cgLong or cgULong. In all cases, the } { amount to increment by is a positive signed integer. } { } { } { pc_ind - load indirect } { } { Gen1t (pc_ind, disp, type) } { } { A value of type TYPE is loaded from DISP bytes past the } { address that is on the evaluation stack. The address is } { removed from the stack and replaced with the value. } { } { } { pc_ior - logical or } { pc_lor - long logical or } { } { Gen0(pc_ior) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_lor) cgLong,cgULong } { } { The two values on the top of the evaluation stack are } { removed and ored. The result is placed back on the stack. } { Zero is treated as false, and any other value as true. The } { or is a logical or. See pc_bor for a bitwise or. } { } { } { pc_ixa - integer indexed address } { } { Gen0t(pc_ixa, type) } { } { TOS is an integer, which is added to TOS-1, which is a long } { integer. This instruction is generally used for computing } { short array indexes. } { } { TYPE can be cgWord or cgUWord; the type indicates whether } { the addition is signed or unsigned. } { } { } { pc_lad - load the address of a subroutine } { } { Gen0Name(pc_lad, name); } { } { Loads the address of the subroutine NAME. } { } { } { pc_lao - load a global address } { } { Gen1Name(pc_lao, disp, name); } { } { Loads the address of DISP bytes past the global variable } { NAME onto the stack. } { } { } { pc_lbf - load bit field } { pc_lbu - load unsigned bit field } { } { Gen2t(pc_lbf, disp, size, type) } { Gen2t(pc_lbu, disp, size, type) } { } { A bit field SIZE bits wide is loaded from DISP bits past the } { address on the top of the evaluation stack. The address is } { removed from the evaluation stack in the process. pc_lbf } { loads a signed value, while pc_lbu loads an unsigned value. } { } { } { pc_lca - load a string constant address } { } { GenS(pc_lca, str) } { } { Loads the address of a string onto the stack. Str is a } { pointer to a string constant. } { } { } { pc_lda - load a local address } { } { Gen2(pc_lda, label, disp) } { } { Loads the address of DISP bytes past the local label LABEL. } { } { } { pc_ldc - load a constant } { } { Gen1t(pc_ldc, val, type) } { GenLdcLong(val) } { GenLdcReal(val) } { } { Loads a constant value. Special calls for long and real } { values are provided due to the unique parameter requirements.} { } { } { pc_ldo - load from a global variable } { } { Gen1tName (pc_ldo, disp, type, name) } { } { Loads a value from the global label NAME and places it on } { the evaluation stack. DISP is a fixed displacement past the } { names label to load from. (Used for records.) TYPE is } { the type of the value being loaded. } { } { } { pc_lil - increment and load from a local variable } { pc_lli - load a local variable, then inc the original } { pc_ldl - decrement and load from a local variable } { pc_lld - load a local variable, then dec the original } { } { Gen2t(pc_lli, label, inc, type) } { } { Loads a value from the local label LABEL and places it on } { the evaluation stack. TYPE is the type of the value being } { loaded. INC is the number to increment or decrement by. } { } { In addition to loading the value, these instructions also } { increment or decrement the value, as indicated in the } { comment by the instruction name. The operand is incremented } { or decremented by INC. INC must be 1 for one and two byte } { operands. } { } { } { pc_lod - load from a local variable } { } { Gen2t(pc_lod, label, disp, type) } { } { Loads a value from DISP bytes past the local label LABEL and } { places it on the evaluation stack. TYPE is the type is the } { value being loaded. } { } { } { pc_mod - integer modulus } { pc_uim - unsigned integer modulus } { pc_mdl - long modulus } { pc_ulm - unsigned long modulus } { } { Gen0(pc_mod) cgByte,cgWord } { Gen0(pc_uim) cgUByte,cgUWord } { Gen0(pc_mdl) cgLong } { Gen0(pc_ulm) cgULong } { } { The two values on the top of the evaluation stack are } { removed and a molulus operation is performed. The result is } { placed back on the stack. The result, like the arguments, } { is an integer. } { } { } { pc_mpi - integer multiply } { pc_umi - unsigned integer multiply } { pc_mpl - long integer multiply } { pc_uml - unsigned long multiply } { pc_mpr - real multiply } { } { Gen0(pc_mpi) cgByte,cgWord } { Gen0(pc_umi) cgUByte,cgUWord } { Gen0(pc_mpl) cgLong } { Gen0(pc_uml) cgULong } { Gen0(pc_mpr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } { removed and multiplied. The result is placed back on the } { stack. The result type is the same as the argument type. } { } { } { pc_ngi - integer negation } { pc_ngl - long negation } { pc_ngr - real negation } { } { Gen0(pc_ngi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_ngl) cgLong,cgULong } { Gen0(pc_ngr) cgReal,cgDouble,cgComp,cgExtended } { } { The value on the top of the evaluation stack is removed, } { subtracted from 0, and replaced. (Two's compliment.) } { } { } { Gen0(pc_nop) } { } { This operand is a leaf node. It does nothing. It is used } { to create a null expression tree for functions and } { procedures that have no parameters. } { } { } { pc_not - logical negation } { } { Gen0(pc_not) } { } { The value on the top of the evaluation stack is removed, } { logically negated, and replaced. } { } { } { pc_pop - pop a value from the stack } { } { Gen0t(pc_pop, type) } { } { The value on the top of the evaluation stack is removed. } { } { } { pc_psh - push bytes on the stack } { } { Gen0(pc_psh) } { } { Removes the size (a word) and the source address (a long) } { from the evaluation stack, and pushes size bytes from the } { source address onto the stack. } { } { } { pc_sbf - save bit field } { } { Gen2t(pc_sbf, disp, size, type) } { } { An integer is removed from the top of the evaluation stack } { and saved at the address on the evaluation stack. The } { value is saved DISP bits past the address, and is treated as } { a SIZE bit value. Extra bits are dropped. } { } { } { pc_sbi - integer subtraction } { pc_sbl - long subtraction } { pc_sbr - real subtraction } { } { Gen0(pc_sbi) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_sbl) cgLong,cgULong } { Gen0(pc_sbr) cgReal,cgDouble,cgComp,cgExtended } { } { The two values on the top of the evaluation stack are } { removed. TOS-1 - TOS is placed back on the stack. } { } { } { pc_shl - shift left } { pc_sll - shift left long } { } { Gen0(pc_shl) cgByte,cgUByte,cgWord,cgUWord } { Gen0(pc_sll) cgLong,cgULong } { } { The value at tos-1 is shifted left by the number of bits } { specified by tos. The result is an integer, which replaces } { the operands on the stack. The right bit positions are } { filled with zeros. } { } { } { pc_shr - shift right } { pc_usr - unsigned shift right } { pc_slr - long shift right } { pc_vsr - unsigned long shift right } { } { Gen0(pc_shr) cgByte,cgWord } { Gen0(pc_usr) cgUByte,cgUWord } { Gen0(pc_slr) cgLong } { Gen0(pc_vsr) cgULong } { } { The value at tos-1 is shifted right by the number of bits } { specified by tos. The result is an integer, which replaces } { the operands on the stack. This is a signed shift: the } { leftmost bit position is filled in with a copy of the } { orignial leftmost bit. } { } { Pc_usr is the unsigned form. The operation is the same, } { except that the leftmost bit is replaced with a zero. } { Pc_vsr is used for unsigned long operations. } { } { pc_stk - stack an operand } { } { Gen0t(pc_stk, type) } { } { The value on top of the evaluation stack is to be left there } { as a parameter to a subsequent procedure or function call. } { This p-code "caps" the expression tree, giving the code } { generator something to do with the expression result. } { } { } { pc_sro - store to a global variable } { } { Gen1tName (pc_sro, disp, type, name) } { } { Saves the value from the top of the evaluation stack to the } { global label NAME. DISP is a fixed displacement past the } { names label to load from. (Used for records.) TYPE is } { the type of the value being loaded. } { } { } { pc_sto - store indirect } { } { Gen0t(pc_sto, type) } { } { Two values are removed from the evaluation stack. TOS is of } { type TYPE, while TOS-1 is a pointer. The value is stored at } { the location pointed to by the pointer. } { } { } { pc_str - store to a local variable } { } { Gen2t(pc_str, label, disp, type) } { } { Saves the value on the top of the evaluation stack to DISP } { bytes past the local label LABEL. TYPE is the type of the } { value being saved. } { } { } { pc_tri - C trinary operator } { } { Gen0t(pc_tri, type) } { } { Implements the C trinary operator. TOS is the false } { expression, TOS-1 the true expression, and TOS-2 the } { condition expression. The condition expression is } { evaluated. If it is non-zero, the true expression is } { evaluated. If it is zero, the false expression is } { evaluated. The result type of the true and false } { expressions must be the same. } { } { Internally, pc_bno is used for the right operand; the } { operands for pc_bno are the two expressions. } { } {-- Flow of control --------------------------------------------} { } { dc_lab - define a label } { } { Gen1(pc_lab, lab) } { } { Defines label number lab at the current location. } { } { } { pc_add - address } { } { Gen1(pc_add, lab) } { } { Generates a two-byte address that points to the label lab. } { This is used to create branch tables for pc_xjp } { instructions. } { } { } { pc_fjp - jump if false } { } { Gen1(pc_fjp, lab) } { } { A boolean value is removed from the top of the evaluation } { stack. If the value is false, execution continues with the } { instruction after the label lab; otherwise execution } { continues with the instruction after this one. } { } { } { pc_tjp - jump if true } { } { Gen1(pc_tjp, lab) } { } { A boolean value is removed from the top of the evaluation } { stack. If the value is true, execution continues with the } { instruction after the label lab; otherwise execution } { continues with the instruction after this one. } { } { } { pc_ujp - jump } { } { Gen1(pc_ujp, lab) } { } { Execution continues with the instruction after the label lab.} { } { } { pc_xjp - indexed jump } { } { Gen1(pc_xjp, val) } { } { The top of stack contains an integer, which is removed. If } { it is less than zero or greater than VAL, it is replaced by } { VAL. The result is then used to index into a jump table, } { formed using pc_add instructions, which follows immediately } { after the pc_xjp instruction. } { } {-- Pcodes involved with calling and defining procedures -------} { } { dc_str - start a segment } { } { Gen2Name(dc_str, p1, p2, name) } { } { Starts a new object segment with the name name^. P1 is the } { segment kind, while p2 is the length code (1 for data, 0 for } { code segments). } { } { } { dc_pin - procedure entry point } { } { Gen0(dc_pin) } { } { A code segment does not have to be entered at the first byte } { when called. This directive is used one time in each code } { segment to indicate the actual entry point. } { } { } { dc_enp - end a segment } { } { Gen0(dc_enp) } { } { This directive closes the current segment. } { } { } { pc_ent - enter a subroutine } { } { Gen0(pc_ent) } { } { This pcode is used at the beginning of every subroutine. It } { marks the beginning of a new stack frame definition. } { Subsequent dc_loc and dc_prm cause space to be allocated } { from this stack frame. } { } { } { pc_ret - return from a subroutine } { } { Gen0t(pc_ret, type) } { } { This pcode is used to return from a function or a procedure. } { The type is the type of the function, and is used to tell } { the code generator what type of value to return. The value } { to return is assumed to be stored defaultStackSize bytes } { into the stack frame. } { } { } { pc_cui - call user procedure, indirect } { } { Gen1t(pc_cui, repair, ftype) } { } { Calls a user procedure or function through the address on } { the top of the evaluation stack. FTYPE is the return type. } { Repair is 1 if stack repair should be forced, and 0 if not. } { } { } { pc_cup - call user procedure } { } { Gen1tName(pc_cup, repair, name, ftype) } { } { Calls a user procedure or function. Ftype is the type. } { Repair is 1 if stack repair should be forced, and 0 if not. } { NAME is the name of the procedure. } { } { } { dc_loc - define local label } { } { Gen2(dc_loc, label, size) } { } { Defines a local label using the label parameter as a label } { number. Size bytes are reserved on the stack frame. Label } { numbers should be assigned by the compiler, starting with } { number 1. Label 0 is reserved for refering to the return } { value of a function (if any). } { } { } { dc_prm - define parameter } { } { Gen3(dc_prm, label, size, disp) } { } { Defines a label used to refer to a parameter. See dc_loc } { for a discussion of the label and size parameters. The disp } { parameter is the number of bytes of parameter that will be } { pushed after this one; i.e., the disp from the return addr } { to this parameter. } { } { } { pc_tl1 - call a tool } { } { GenTool(pc_tl1, toolNum, retSize, dispatcher) } { } { Calls a tool. The tool number is toolNum; the tool is } { called at location dispatcher. The tool returns a result } { that is retSize bytes long. } { } { } { dc_sym - generate a symbol table } { } { Gen1Name(dc_sym, doGLobals, pointer(table) } { } { Generates a symbol table for the debugger. TABLE is the } { address of the sybol table, which will be passed back to a } { subroutine called GenSymbols, which must be supplied by the } { compiler. DOGLOBALS is a flag the compiler can set for its } { own purposes. C uses the flag to note that the symbol } { table being created is for main, so global symbols should be } { included. } { } \ No newline at end of file diff --git a/CGI.Debug b/CGI.Debug new file mode 100755 index 0000000..6a7b4d5 --- /dev/null +++ b/CGI.Debug @@ -0,0 +1 @@ +procedure InitWriteCode; {debug} { initialize the intermediate code opcode table } begin {InitWriteCode} opt[pc_adi] := 'adi'; opt[pc_adr] := 'adr'; opt[pc_psh] := 'psh'; opt[pc_and] := 'and'; opt[pc_dvi] := 'dvi'; opt[pc_dvr] := 'dvr'; opt[pc_cnn] := 'cnn'; opt[pc_cnv] := 'cnv'; opt[pc_ior] := 'ior'; opt[pc_mod] := 'mod'; opt[pc_mpi] := 'mpi'; opt[pc_mpr] := 'mpr'; opt[pc_ngi] := 'ngi'; opt[pc_ngr] := 'ngr'; opt[pc_not] := 'not'; opt[pc_sbi] := 'sbi'; opt[pc_sbr] := 'sbr'; opt[pc_sto] := 'sto'; opt[pc_dec] := 'dec'; opt[dc_loc] := 'LOC'; opt[pc_ent] := 'ent'; opt[pc_fjp] := 'fjp'; opt[pc_inc] := 'inc'; opt[pc_ind] := 'ind'; opt[pc_ixa] := 'ixa'; opt[pc_lao] := 'lao'; opt[pc_lca] := 'lca'; opt[pc_ldo] := 'ldo'; opt[pc_mov] := 'mov'; opt[pc_ret] := 'ret'; opt[pc_sro] := 'sro'; opt[pc_xjp] := 'xjp'; opt[pc_cup] := 'cup'; opt[pc_equ] := 'equ'; opt[pc_geq] := 'geq'; opt[pc_grt] := 'grt'; opt[pc_lda] := 'lda'; opt[pc_ldc] := 'ldc'; opt[pc_ldl] := 'ldl'; opt[pc_leq] := 'leq'; opt[pc_les] := 'les'; opt[pc_lil] := 'lil'; opt[pc_lld] := 'lld'; opt[pc_lli] := 'lli'; opt[pc_lod] := 'lod'; opt[pc_neq] := 'neq'; opt[pc_str] := 'str'; opt[pc_ujp] := 'ujp'; opt[pc_add] := 'add'; opt[pc_lnm] := 'lnm'; opt[pc_nam] := 'nam'; opt[pc_cui] := 'cui'; opt[pc_lad] := 'lad'; opt[pc_tjp] := 'tjp'; opt[dc_lab] := 'LAB'; opt[pc_usr] := 'usr'; opt[pc_umi] := 'umi'; opt[pc_udi] := 'udi'; opt[pc_uim] := 'uim'; opt[dc_enp] := 'ENP'; opt[pc_stk] := 'stk'; opt[dc_glb] := 'GLB'; opt[dc_dst] := 'DST'; opt[dc_str] := 'STR'; opt[pc_cop] := 'cop'; opt[pc_cpo] := 'cpo'; opt[pc_tl1] := 'tl1'; opt[dc_pin] := 'PIN'; opt[pc_shl] := 'shl'; opt[pc_shr] := 'shr'; opt[pc_bnd] := 'bnd'; opt[pc_bor] := 'bor'; opt[pc_bxr] := 'bxr'; opt[pc_bnt] := 'bnt'; opt[pc_bnl] := 'bnl'; opt[pc_mpl] := 'mpl'; opt[pc_dvl] := 'dvl'; opt[pc_mdl] := 'mdl'; opt[pc_sll] := 'sll'; opt[pc_slr] := 'slr'; opt[pc_bal] := 'bal'; opt[pc_ngl] := 'ngl'; opt[pc_adl] := 'adl'; opt[pc_sbl] := 'sbl'; opt[pc_blr] := 'blr'; opt[pc_blx] := 'blx'; opt[dc_sym] := 'SYM'; opt[pc_lnd] := 'lnd'; opt[pc_lor] := 'lor'; opt[pc_vsr] := 'vsr'; opt[pc_uml] := 'uml'; opt[pc_udl] := 'udl'; opt[pc_ulm] := 'ulm'; opt[pc_pop] := 'pop'; opt[pc_gil] := 'gil'; opt[pc_gli] := 'gli'; opt[pc_gdl] := 'gdl'; opt[pc_gld] := 'gld'; opt[pc_iil] := 'iil'; opt[pc_ili] := 'ili'; opt[pc_idl] := 'idl'; opt[pc_ild] := 'ild'; opt[pc_cpi] := 'cpi'; opt[pc_tri] := 'tri'; opt[pc_lbu] := 'lbu'; opt[pc_lbf] := 'lbf'; opt[pc_sbf] := 'sbf'; opt[pc_cbf] := 'cbf'; opt[dc_cns] := 'CNS'; opt[dc_prm] := 'PRM'; opt[pc_nat] := 'nat'; opt[pc_bno] := 'bno'; opt[pc_nop] := 'nop'; end; {InitWriteCode} procedure PrintDAG (tag: stringPtr; code: icptr); { print a DAG } { } { parameters: } { tag - label for lines } { code - first node in DAG } begin {PrintDAG} while code <> nil do begin PrintDAG(tag, code^.left); PrintDAG(tag, code^.right); write(tag^); WriteCode(code); code := code^.next; end; {while} end; {PrintDAG} procedure PrintBlocks {tag: stringPtr; bp: blockPtr}; {debug} { print a series of basic blocks } { } { parameters: } { tag - label for lines } { bp - first block to print } procedure PrintDOM (dp: blockListPtr); { print a list of dominators } { } { parameters: } { dp - list to print } begin {PrintDOM} while dp <> nil do begin write(dp^.dfn:1); if dp^.next <> nil then write(','); dp := dp^.next; end; {while} end; {PrintDOM} procedure PrintList (tag: stringPtr; lp: iclist); { print an operation list } { } { parameters: } { tag - label for lines } { lp - list to print } procedure PrintTree (tag: stringPtr; op: icptr); { print an operation tree } { } { parameters: } { tag - label for lines } { op - operation tree to print } begin {PrintTree} if op^.left <> nil then printTree(@'>> : ', op^.left); if op^.right <> nil then printTree(@'>> : ', op^.right); write(tag^); WriteCode(op); end; {PrintTree} begin {PrintList} while lp <> nil do begin PrintTree(tag, lp^.op); lp := lp^.next; end; {while} end; {PrintList} begin {PrintBlocks} while bp <> nil do begin write(tag^, 'BLOCK(', bp^.dfn:1, ') ['); PrintDOM(bp^.dom); writeln(']'); PrintList(@'>>In : ', bp^.c_in); PrintList(@'>>Out : ', bp^.c_out); PrintList(@'>>Gen : ', bp^.c_gen); PrintDAG(tag, bp^.code); bp := bp^.next; end; {while} end; {PrintBlocks} procedure WriteCode {code: icptr}; {debug} { print an intermediate code instruction } { } { Parameters: } { code - intermediate code instruction to write } var i: integer; {work variable} procedure WriteType(tp: baseTypeEnum); { print the operand type } { } { parameters: } { tp - type } begin {WriteType} case tp of cgByte: write('b'); cgUByte: write('ub'); cgWord: write('i'); cgUWord: write('u'); cgLong: write('l'); cgULong: write('ul'); cgReal: write('r'); cgDouble: write('d'); cgComp: write('c'); cgExtended: write('e'); cgString: write('s'); cgVoid: write('void'); ccPointer: write('p'); otherwise: write('(', ord(tp):1, ')'); end; {case} end; {WriteType} begin {WriteCode} write(opt[code^.opcode]); with code^ do case opcode of dc_enp,dc_pin,dc_sym,pc_adl,pc_bal,pc_dvl,pc_ent,pc_mpl,pc_sbl, pc_uml,pc_adr,pc_dvr,pc_mpr,pc_adi,pc_sbi,pc_mpi,pc_dvi, pc_umi,pc_shl,pc_nop,pc_and,pc_lnd,pc_bnd,pc_lor,pc_ior,pc_bxr, pc_bnt,pc_blx,pc_bnl,pc_ngi,pc_ngl,pc_ngr,pc_ixa,pc_mdl, pc_udi,pc_udl: ; dc_prm: write(' ', q:1, ':', r:1, ':', s:1); pc_equ,pc_neq,pc_geq,pc_leq,pc_grt,pc_les,pc_pop,pc_ret,pc_bno, pc_cpi,pc_sto,pc_tri,pc_stk,pc_idl,pc_iil,pc_ili,pc_ild: WriteType(optype); pc_cnv,pc_cnn: begin write(' '); i := (q>>4) & 15; WriteType(baseTypeEnum(i)); write(':'); i := q & 15; WriteType(baseTypeEnum(i)); end; pc_lil,pc_lli,pc_ldl,pc_lld: begin WriteType(optype); write(' ', q:1, ',', r:1); end; pc_lod,pc_str,pc_cop: begin WriteType(optype); write(' ', r:1, ':', q:1); end; dc_loc,pc_lda,pc_mov: write(' ', r:1, ':', q:1); pc_ind,pc_inc,pc_dec: begin WriteType(optype); write(' ', q:1); end; dc_lab,pc_fjp,pc_tjp,pc_ujp,pc_add: write(' ', q:1); pc_ldc: begin WriteType(optype); if optype in [cgByte,cgUByte,cgWord,cgUWord] then write(' ', q:1) else if optype in [cgLong,cgULong] then write(' ', lval:1) else if optype in [cgReal,cgDouble,cgComp,cgExtended] then write(' ', rval:1) else write('***'); end; pc_cup,pc_lad: begin WriteType(optype); write(' ', lab^); end; pc_cpo,pc_lao,pc_ldo,pc_sro: begin WriteType(optype); write(' ', q:1, ':', lab^); end; dc_str,dc_glb,pc_gli,pc_gld,pc_gil,pc_gdl: write(' ', r:1, ':', q:1, ':', lab^); dc_cns: begin WriteType(optype); write(' ', q:1, ':'); case optype of cgByte,cgUByte,cgWord,cgUWord: write(r:1); cgLong,cgULong: write(lval:1); cgReal,cgDouble,cgComp,cgExtended: write('***'); cgString: begin write(''''); for i := 1 to q do write(str^.str[i]); write(''''); end; ccPointer: if lab = nil then write('***') else write(lab^, '+', pval:1); end; {case} end; pc_lca: begin WriteType(optype); write(' '); if optype = cgString then begin write(''''); for i := 1 to q do write(str^.str[i]); write(''''); end {if} else write('***'); end; otherwise: write(' ***'); end; {case} writeln; end; {WriteCode} \ No newline at end of file diff --git a/CGI.pas b/CGI.pas new file mode 100755 index 0000000..610e679 --- /dev/null +++ b/CGI.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ORCA Code Generator Interface } { } { This unit serves as the glue code attaching a compiler } { to the code generator. It provides subroutines in a } { format that is convinient for the compiler during } { semantic analysis, and produces intermediate code records } { as output. These intermediate code records are then } { passed on to the code generator for optimization and } { native code generation. } { } {$copy 'cgi.comments'} {---------------------------------------------------------------} unit CodeGeneratorInterface; interface {$segment 'cg'} {$LibPrefix '0/obj/'} uses CCommon; const {Error interface: these constants map } {code generator error numbers into the } {numbers used by the compiler's Error } {subroutine. } {--------------------------------------} cge1 = 57; {compiler error} cge2 = 58; {implementation restriction: too many local labels} cge3 = 60; {implementation restriction: string space exhausted} {65816 native code generation} {----------------------------} {instruction modifier flags} shift8 = 1; {shift operand left 8 bits} shift16 = 2; {shift operand left 16 bits} toolCall = 4; {generate a tool call} stringReference = 8; {generate a string reference} isPrivate = 32; {is the label private?} constantOpnd = 64; {the absolute operand is a constant} localLab = 128; {the operand is a local lab} m_adc_abs = $6D; {op code #s for 65816 instructions} m_adc_dir = $65; m_adc_imm = $69; m_adc_s = $63; m_and_abs = $2D; m_and_dir = $25; m_and_imm = $29; m_and_s = $23; m_asl_a = $0A; m_bcc = $90; m_bcs = $B0; m_beq = $F0; m_bit_imm = $89; m_bmi = $30; m_bne = $D0; m_bpl = $10; m_bra = $80; m_brl = $82; m_bvs = $70; m_clc = $18; m_cmp_abs = $CD; m_cmp_dir = $C5; m_cmp_dirX = $D5; m_cmp_imm = $C9; m_cmp_long = $CF; m_cmp_s = $C3; m_cop = $02; m_cpx_abs = 236; m_cpx_dir = 228; m_cpx_imm = 224; m_dea = 58; m_dec_abs = 206; m_dec_absX = $DE; m_dec_dir = 198; m_dec_dirX = 214; m_dex = 202; m_dey = 136; m_eor_abs = 77; m_eor_dir = 69; m_eor_imm = 73; m_eor_s = 67; m_ina = 26; m_inc_abs = 238; m_inc_absX = $FE; m_inc_dir = 230; m_inc_dirX = 246; m_inx = 232; m_iny = 200; m_jml = 92; m_jsl = 34; m_lda_abs = 173; m_lda_absx = 189; m_lda_dir = 165; m_lda_dirx = 181; m_lda_imm = 169; m_lda_indl = 167; m_lda_indly = 183; m_lda_long = 175; m_lda_longx = 191; m_lda_s = 163; m_ldx_abs = 174; m_ldx_dir = 166; m_ldx_imm = 162; m_ldy_abs = 172; m_ldy_absX = 188; m_ldy_dir = 164; m_ldy_dirX = 180; m_ldy_imm = 160; m_lsr_a = 74; m_mvn = 84; m_ora_abs = 13; m_ora_dir = 5; m_ora_dirX = 21; m_ora_imm = 9; m_ora_longX = 31; m_ora_s = 3; m_pea = 244; m_pei_dir = 212; m_pha = 72; m_phb = 139; m_phd = 11; m_phx = 218; m_phy = 90; m_php = 8; m_pla = 104; m_plb = 171; m_pld = 43; m_plx = 250; m_ply = 122; m_plp = 40; m_rep = 194; m_rtl = 107; m_rts = 96; m_sbc_abs = 237; m_sbc_dir = 229; m_sbc_imm = 233; m_sbc_s = 227; m_sec = 56; m_sep = 226; m_sta_abs = 141; m_sta_absX = 157; m_sta_dir = 133; m_sta_dirX = 149; m_sta_indl = 135; m_sta_indlY = 151; m_sta_long = 143; m_sta_longX = 159; m_sta_s = 131; m_stx_dir = 134; m_stx_abs = 142; m_sty_abs = 140; m_sty_dir = 132; m_sty_dirX = 148; m_stz_abs = 156; m_stz_absX = 158; m_stz_dir = 100; m_stz_dirX = 116; m_tax = 170; m_tay = 168; m_tcd = 91; m_tcs = 27; m_tdc = 123; m_tsx = $BA; m_txa = 138; m_txs = $9A; m_txy = 155; m_tya = 152; m_tyx = 187; m_tsb_dir = $04; m_tsb_abs = $0C; m_tsc = 59; m_xba = $EB; d_lab = 256; d_end = 257; d_bmov = 258; d_add = 259; d_pin = 260; d_wrd = 261; d_sym = 262; d_cns = 263; max_opcode = 263; {Code Generation} {---------------} maxCBuff = 191; {length of constant buffer} {Note: maxlabel is also defined in CCommon.pas} {Note: maxlabel is also defined in objout.asm} maxLabel = 2400; {max # of internal labels} maxLocalLabel = 200; {max # local variables} maxString = 8000; {max # chars in string space} {size of internal types} {----------------------} cgByteSize = 1; cgWordSize = 2; cgLongSize = 4; cgPointerSize = 4; cgRealSize = 4; cgDoubleSize = 8; cgCompSize = 8; cgExtendedSize = 10; type segNameType = packed array[1..10] of char; {segment name} {p code} {------} pcodes = {pcode names} (pc_adi,pc_adr,pc_and,pc_dvi,pc_dvr,pc_cnn,pc_cnv,pc_ior,pc_mod,pc_mpi, pc_mpr,pc_ngi,pc_ngr,pc_not,pc_sbi,pc_sbr,pc_sto,pc_dec,dc_loc,pc_ent, pc_fjp,pc_inc,pc_ind,pc_ixa,pc_lao,pc_lca,pc_ldo,pc_mov,pc_ret,pc_sro, pc_xjp,pc_cup,pc_equ,pc_geq,pc_grt,pc_lda,pc_ldc,pc_ldl,pc_leq,pc_les, pc_lil,pc_lld,pc_lli,pc_lod,pc_neq,pc_str,pc_ujp,pc_add,pc_lnm,pc_nam, pc_cui,pc_lad,pc_tjp,dc_lab,pc_usr,pc_umi,pc_udi, pc_uim,dc_enp,pc_stk,dc_glb,dc_dst,dc_str,pc_cop,pc_cpo,pc_tl1, dc_pin,pc_shl,pc_shr,pc_bnd,pc_bor,pc_bxr,pc_bnt,pc_bnl,pc_mpl,pc_dvl, pc_mdl,pc_sll,pc_slr,pc_bal,pc_ngl,pc_adl,pc_sbl,pc_blr,pc_blx, dc_sym,pc_lnd,pc_lor,pc_vsr,pc_uml,pc_udl,pc_ulm,pc_pop,pc_gil, pc_gli,pc_gdl,pc_gld,pc_cpi,pc_tri,pc_lbu,pc_lbf,pc_sbf,pc_cbf,dc_cns, dc_prm,pc_nat,pc_bno,pc_nop,pc_psh,pc_ili,pc_iil,pc_ild,pc_idl); {intermediate code} {-----------------} icptr = ^intermediate_code; intermediate_code = record {intermediate code record} opcode: pcodes; {operation code} q,r,s: integer; {operands} lab: stringPtr; {named label pointer} next: icptr; {ptr to next statement} left, right: icptr; {leaves for trees} parents: integer; {number of parents} case optype: baseTypeEnum of cgByte, cgUByte, cgWord, cgUWord : (opnd: longint; llab,slab: integer); cgLong, cgULong : (lval: longint); cgReal, cgDouble, cgComp, cgExtended : (rval: double); cgString : (str: longStringPtr); cgVoid, ccPointer : (pval: longint; pstr: longStringPtr); end; {basic blocks} {------------} iclist = ^iclistRecord; {used to form lists of records} iclistRecord = record next: iclist; op: icptr; end; blockPtr = ^block; {basic block edges} blockListPtr = ^blockListRecord; {lists of blocks} block = record last, next: blockPtr; {for doubly linked list of blocks} dfn: integer; {depth first order index} visited: boolean; {has this node been visited?} code: icptr; {code in the block} c_in: iclist; {list of reaching definitions} c_out: iclist; {valid definitions on exit} c_gen: iclist; {generated definitions} dom: blockListPtr; {dominators of this block} end; blockListRecord = record {lists of blocks} next, last: blockListPtr; dfn: integer; end; {65816 native code generation} {----------------------------} addressingMode = (implied,immediate, {65816 addressing modes} longabs,longrelative,relative,absolute,direct,gnrLabel,gnrSpace, gnrConstant,genaddress,special,longabsolute); var {current instruction info} {------------------------} isJSL: boolean; {is the current opcode a jsl?} {65816 native code generation} {----------------------------} longA,longI: boolean; {register sizes} {variables used to control the } {quality or characteristics of } {code } {------------------------------} checkStack: boolean; {check stack for stack errors?} cLineOptimize: boolean; {+o flag set?} code: icptr; {current intermediate code record} codeGeneration: boolean; {is code generation on?} commonSubexpression: boolean; {do common subexpression removal?} currentSegment,defaultSegment: segNameType; {current & default seg names} segmentKind: integer; {kind field of segment (ored with start/data)} debugFlag: boolean; {generate debugger calls?} dataBank: boolean; {save, restore data bank?} floatCard: integer; {0 -> SANE; 1 -> FPE} floatSlot: integer; {FPE slot} loopOptimizations: boolean; {do loop optimizations?} noroot: boolean; {prevent creation of .root file?} npeephole: boolean; {do native code peephole optimizations?} peephole: boolean; {do peephole optimization?} profileFlag: boolean; {generate profiling code?} rangeCheck: boolean; {generate range checks?} registers: boolean; {do register optimizations?} rtl: boolean; {return with an rtl?} saveStack: boolean; {save, restore caller's stack reg?} smallMemoryModel: boolean; {is the small model in use?} stackSize: integer; {amount of stack space to reserve} strictVararg: boolean; {repair stack around vararg calls?} stringsize: 0..maxstring; {amount of string space left} stringspace: packed array[1..maxstring] of char; {string table} symLength: integer; {length of debug symbol table} toolParms: boolean; {generate tool format paramaters?} volatile: boolean; {has a volatile qualifier been used?} {desk accessory variables} {------------------------} isNewDeskAcc: boolean; {is this a new desk acc?} isClassicDeskAcc: boolean; {is this a classic desk acc?} isCDev: boolean; {is this a control panel device?} isNBA: boolean; {is this a new button action?} isXCMD: boolean; {is this an XCMD?} openName,closeName,actionName, {names of the required procedures} initName: stringPtr; refreshPeriod: integer; {refresh period} eventMask: integer; {event mask} menuLine: pString; {name in menu bar} {DAG construction} {----------------} DAGhead: icPtr; {1st ic in DAG list} DAGblocks: blockPtr; {list of basic blocks} {---------------------------------------------------------------} procedure CodeGenFini; { terminal processing } procedure CodeGenInit (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean); { code generator initialization } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } procedure CodeGenScalarInit; { initialize codegen scalars } {procedure InitWriteCode; {debug} { initialize the intermediate code opcode table } procedure Gen0 (fop: pcodes); { generate an implied operand instruction } { } { parameters: } { fop - operation code } procedure Gen1 (fop: pcodes; fp2: integer); { generate an instruction with one numeric operand } { } { parameters: } { fop - operation code } { fp2 - operand } procedure Gen2 (fop: pcodes; fp1, fp2: integer); { generate an instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } procedure Gen3 (fop: pcodes; fp1, fp2, fp3: integer); { generate an instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - third operand } procedure Gen0Name (fop: pcodes; name: stringPtr); { generate a p-code with a name } { } { parameters: } { fop - operation code } { name - named label } procedure Gen1Name (fop: pcodes; fp1: integer; name: stringPtr); { generate a one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { name - named label } procedure Gen2Name (fop: pcodes; fp1, fp2: integer; name: stringPtr); { generate a two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { name - named label } procedure Gen0tName (fop: pcodes; tp: baseTypeEnum; name: stringPtr); { generate a typed zero operand p-code with a name } { } { parameters: } { fop - operation code } { tp - base type } { name - named label } procedure Gen1tName (fop: pcodes; fp1: integer; tp: baseTypeEnum; name: stringPtr); { generate a typed one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { tp - base type } { name - named label } procedure Gen2tName (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum; name: stringPtr); { generate a typed two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } { name - named label } procedure Gen0t (fop: pcodes; tp: baseTypeEnum); { generate a typed implied operand instruction } { } { parameters: } { fop - operation code } { tp - base type } procedure Gen1t (fop: pcodes; fp1: integer; tp: baseTypeEnum); { generate a typed instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - operand } { tp - base type } procedure Gen2t (fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum); { generate a typed instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } procedure Gen3t (fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum); { generate a typed instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - second operand } { tp - base type } procedure GenPS (fop: pcodes; str: stringPtr); { generate an instruction that uses a p-string operand } { } { parameters: } { fop - operation code } { str - pointer to string } procedure GenS (fop: pcodes; str: longstringPtr); { generate an instruction that uses a string operand } { } { parameters: } { fop - operation code } { str - pointer to string } procedure GenL1 (fop: pcodes; lval: longint; fp1: integer); { generate an instruction that uses a longint and an int } { } { parameters: } { lval - longint parameter } { fp1 - integer parameter } procedure GenR1t (fop: pcodes; rval: double; fp1: integer; tp: baseTypeEnum); { generate an instruction that uses a real and an int } { } { parameters: } { rval - real parameter } { fp1 - integer parameter } { tp - base type } procedure GenLdcLong (lval: longint); { load a long constant } { } { parameters: } { lval - value to load } procedure GenLdcReal (rval: double); { load a real constant } { } { parameters: } { rval - value to load } procedure GenTool (fop: pcodes; fp1, fp2: integer; dispatcher: longint); { generate a tool call } { } { parameters: } { fop - operation code } { fp1 - tool number } { fp2 - return size } { dispatcher - tool entry point } {procedure PrintBlocks (tag: stringPtr; bp: blockPtr); {debug} { print a series of basic blocks } { } { parameters: } { tag - label for lines } { bp - first block to print } function TypeSize (tp: baseTypeEnum): integer; { Find the size, in bytes, of a variable } { } { parameters: } { tp - base type of the variable } {procedure WriteCode (code: icptr); {debug} { print an intermediate code instruction } { } { Parameters: } { code - intermediate code instruction to write } {------------------------------------------------------------------------------} implementation {var opt: array[pcodes] of packed array[1..3] of char; {debug} {Imported from CGC.pas:} function Calloc (bytes: integer): ptr; extern; { Allocate memory from a pool and clear it. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } procedure Error (err: integer); extern; {in scanner.pas} { flag an error } { } { err - error number } function Malloc (bytes: integer): ptr; extern; { Allocate memory from a pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } procedure InitLabels; extern; { initialize the labels array for a procedure } {Imported from ObjOut.pas:} procedure CloseObj; extern; { close the current obj file } {Imported from Native.pas:} procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean); extern; { Set up the object file } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } {Imported from DAG.pas:} procedure DAG (code: icptr); extern; { place an op code in a DAG or tree } { } { parameters: } { code - opcode } {------------------------------------------------------------------------------} { copy 'cgi.debug'} {debug} procedure CodeGenInit {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean}; { code generator initialization } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } begin {CodeGenInit} {initialize the debug tables {debug} {InitWriteCode; {debug} {initialize the label table} InitLabels; codeGeneration := true; {turn on code generation} {set up the DAG variables} DAGhead := nil; {no ics in DAG list} InitFile(keepName, keepFlag, partial); {open the interface file} end; {CodeGenInit} procedure CodeGenFini; { terminal processing } begin {CodeGenFini} CloseObj; {close the open object file} end; {CodeGenFini} procedure CodeGenScalarInit; { initialize codegen scalars } begin {CodeGenScalarInit} isJSL := false; {the current opcode is not a jsl} isNewDeskAcc := false; {assume a normal program} isCDev := false; isClassicDeskAcc := false; isNBA := false; isXCMD := false; codeGeneration := false; {code generation is not turned on yet} currentSegment := ' '; {start with the blank segment} defaultSegment := ' '; smallMemoryModel := true; {small memory model} dataBank := false; {don't save/restore data bank} strictVararg := not cLineOptimize; {save/restore caller's stack around vararg} saveStack := not cLineOptimize; {save/restore caller's stack reg} checkStack := false; {don't check stack for stack errors} stackSize := 0; {default to the launcher's stack size} toolParms := false; {generate tool format parameters?} noroot := false; {create a .root segment} rtl := false; {return with a ~QUIT} floatCard := 0; {use SANE} floatSlot := 0; {default to slot 0} stringSize := 0; {no strings, yet} rangeCheck := false; {don't generate range checks} profileFlag := false; {don't generate profiling code} debugFlag := false; {don't generate debug code} traceBack := false; {don't generate traceback code} volatile := false; {no volatile quialifiers found} registers := cLineOptimize; {don't do register optimizations} peepHole := cLineOptimize; {not doing peephole optimization (yet)} npeepHole := cLineOptimize; commonSubexpression := cLineOptimize; {not doing common subexpression elimination} loopOptimizations := cLineOptimize; {not doing loop optimizations, yet} {allocate the initial p-code} code := pointer(Calloc(sizeof(intermediate_code))); code^.optype := cgWord; end; {CodeGenScalarInit} procedure Gen0 {fop: pcodes}; { generate an implied operand instruction } { } { parameters: } { fop - operation code } begin {Gen0} if codeGeneration then begin {generate the intermediate code instruction} code^.opcode := fop; { if printSymbols then {debug} { WriteCode(code); {debug} DAG(code); {generate the code} {initialize volitile variables for next intermediate code} code := pointer(Calloc(sizeof(intermediate_code))); {code^.lab := nil;} code^.optype := cgWord; end; {if} end; {Gen0} procedure Gen1 {fop: pcodes; fp2: integer}; { generate an instruction with one numeric operand } { } { parameters: } { fop - operation code } { fp2 - operand } begin {Gen1} if codeGeneration then begin if fop = pc_ret then code^.optype := cgVoid; code^.q := fp2; Gen0(fop); end; {if} end; {Gen1} procedure Gen2 {fop: pcodes; fp1, fp2: integer}; { generate an instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } label 1; var lcode: icptr; {local copy of code} begin {Gen2} if codeGeneration then begin lcode := code; case fop of pc_lnm,pc_tl1,pc_lda,dc_loc,pc_mov: begin lcode^.r := fp1; lcode^.q := fp2; end; pc_cnn,pc_cnv: if fp1 = fp2 then goto 1 else if (baseTypeEnum(fp1) in [cgReal,cgDouble,cgComp,cgExtended]) and (baseTypeEnum(fp2) in [cgReal,cgDouble,cgComp,cgExtended]) then goto 1 else if (baseTypeEnum(fp1) in [cgUByte,cgWord,cgUWord]) and (baseTypeEnum(fp2) in [cgWord,cgUWord]) then goto 1 else if (baseTypeEnum(fp1) in [cgByte,cgUByte]) and (baseTypeEnum(fp2) in [cgByte,cgUByte]) then goto 1 else lcode^.q := (fp1 << 4) | fp2; otherwise: Error(cge1); end; {case} Gen0(fop); end; {if} 1: end; {Gen2} procedure Gen3 {fop: pcodes; fp1, fp2, fp3: integer}; { generate an instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - third operand } var lcode: icptr; {local copy of code} begin {Gen3} if codeGeneration then begin lcode := code; lcode^.s := fp1; lcode^.q := fp2; lcode^.r := fp3; Gen0(fop); end; {if} end; {Gen3} procedure Gen0Name {fop: pcodes; name: stringPtr}; { generate a p-code with a name } { } { parameters: } { fop - operation code } { name - named label } begin {Gen0Name} if codeGeneration then begin code^.lab := name; Gen0(fop); end; {if} end; {Gen0Name} procedure Gen1Name {fop: pcodes; fp1: integer; name: stringPtr}; { generate a one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { name - named label } var lcode: icptr; {local copy of code} begin {Gen1Name} if codeGeneration then begin lcode := code; lcode^.q := fp1; lcode^.lab := name; Gen0(fop); end; {if} end; {Gen1Name} procedure Gen2Name {fop: pcodes; fp1, fp2: integer; name: stringPtr}; { generate a two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { name - named label } var lcode: icptr; {local copy of code} begin {Gen2Name} if codeGeneration then begin lcode := code; lcode^.q := fp2; lcode^.r := fp1; lcode^.lab := name; Gen0(fop); end; {if} end; {Gen2Name} procedure Gen0tName {fop: pcodes; tp: baseTypeEnum; name: stringPtr}; { generate a typed zero operand p-code with a name } { } { parameters: } { fop - operation code } { tp - base type } { name - named label } var lcode: icptr; {local copy of code} begin {Gen0tName} if codeGeneration then begin lcode := code; lcode^.lab := name; lcode^.optype := tp; Gen0(fop); end; {if} end; {Gen0tName} procedure Gen1tName {fop: pcodes; fp1: integer; tp: baseTypeEnum; name: stringPtr}; { generate a typed one operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { tp - base type } { name - named label } var lcode: icptr; {local copy of code} begin {Gen1tName} if codeGeneration then begin lcode := code; lcode^.q := fp1; lcode^.lab := name; lcode^.optype := tp; Gen0(fop); end; {if} end; {Gen1tName} procedure Gen2tName {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum; name: stringPtr}; { generate a typed two operand p-code with a name } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } { name - named label } var lcode: icptr; {local copy of code} begin {Gen2tName} if codeGeneration then begin lcode := code; lcode^.r := fp1; lcode^.q := fp2; lcode^.lab := name; lcode^.optype := tp; Gen0(fop); end; {if} end; {Gen2tName} procedure Gen0t {fop: pcodes; tp: baseTypeEnum}; { generate a typed implied operand instruction } { } { parameters: } { fop - operation code } { tp - base type } begin {Gen0t} if codeGeneration then begin code^.optype := tp; Gen0(fop); end; {if} end; {Gen0t} procedure Gen1t {fop: pcodes; fp1: integer; tp: baseTypeEnum}; { generate a typed instruction with one numeric operand } { } { parameters: } { fop - operation code } { fp1 - operand } { tp - base type } var lcode: icptr; {local copy of code} begin {Gen1t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.q := fp1; Gen0(fop); end; {if} end; {Gen1t} procedure Gen2t {fop: pcodes; fp1, fp2: integer; tp: baseTypeEnum}; { generate a typed instruction with two numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { tp - base type } var lcode: icptr; {local copy of code} begin {Gen2t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.r := fp1; lcode^.q := fp2; Gen0(fop); end; {if} end; {Gen2t} procedure Gen3t {fop: pcodes; fp1, fp2, fp3: integer; tp: baseTypeEnum}; { generate a typed instruction with three numeric operands } { } { parameters: } { fop - operation code } { fp1 - first operand } { fp2 - second operand } { fp3 - second operand } { tp - base type } var lcode: icptr; {local copy of code} begin {Gen3t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.s := fp1; lcode^.q := fp2; lcode^.r := fp3; Gen0(fop); end; {if} end; {Gen3t} procedure GenPS {fop: pcodes; str: stringPtr}; { generate an instruction that uses a p-string operand } { } { parameters: } { fop - operation code } { str - pointer to string } var lcode: icptr; {local copy of code} begin {GenPS} if codeGeneration then begin lcode := code; lcode^.optype := cgString; lcode^.q := length(str^); lcode^.str := pointer(ord4(str)-1); Gen0(fop); end; {if} end; {GenPS} procedure GenS {fop: pcodes; str: longstringPtr}; { generate an instruction that uses a string operand } { } { parameters: } { fop - operation code } { str - pointer to string } var lcode: icptr; {local copy of code} begin {GenS} if codeGeneration then begin lcode := code; lcode^.optype := cgString; lcode^.q := str^.length; lcode^.str := str; Gen0(fop); end; {if} end; {GenS} procedure GenL1 {fop: pcodes; lval: longint; fp1: integer}; { generate an instruction that uses a longint and an int } { } { parameters: } { lval - longint parameter } { fp1 - integer parameter } var lcode: icptr; {local copy of code} begin {GenL1} if codeGeneration then begin lcode := code; lcode^.optype := cgLong; lcode^.lval := lval; lcode^.q := fp1; Gen0(fop); end; {if} end; {GenL1} procedure GenR1t {fop: pcodes; rval: double; fp1: integer; tp: baseTypeEnum}; { generate an instruction that uses a real and an int } { } { parameters: } { rval - real parameter } { fp1 - integer parameter } { tp - base type } var lcode: icptr; {local copy of code} begin {GenR1t} if codeGeneration then begin lcode := code; lcode^.optype := tp; lcode^.rval := rval; lcode^.q := fp1; Gen0(fop); end; {if} end; {GenR1t} procedure GenLdcLong {lval: longint}; { load a long constant } { } { parameters: } { lval - value to load } var lcode: icptr; {local copy of code} begin {GenLdcLong} if codeGeneration then begin lcode := code; lcode^.optype := cgLong; lcode^.lval := lval; Gen0(pc_ldc); end; {if} end; {GenLdcLong} procedure GenTool {fop: pcodes; fp1, fp2: integer; dispatcher: longint}; { generate a tool call } { } { parameters: } { fop - operation code } { fp1 - tool number } { fp2 - return size } { dispatcher - tool entry point } var lcode: icptr; {local copy of code} begin {GenTool} if codeGeneration then begin lcode := code; lcode^.q := fp1; lcode^.r := fp2; lcode^.optype := cgLong; lcode^.lval := dispatcher; Gen0(fop); end; {if} end; {GenTool} procedure GenLdcReal {rval: double}; { load a real constant } { } { parameters: } { rval - value to load } var lcode: icptr; {local copy of code} begin {GenLdcReal} if codeGeneration then begin lcode := code; lcode^.optype := cgReal; lcode^.rval := rval; Gen0(pc_ldc); end; {if} end; {GenLdcReal} function TypeSize {tp: baseTypeEnum): integer}; { Find the size, in bytes, of a variable } { } { parameters: } { tp - base type of the variable } begin {TypeSize} case tp of cgByte,cgUByte: TypeSize := cgByteSize; cgWord,cgUWord: TypeSize := cgWordSize; cgLong,cgULong: TypeSize := cgLongSize; cgReal: TypeSize := cgRealSize; cgDouble: TypeSize := cgDoubleSize; cgComp: TypeSize := cgCompSize; cgExtended: TypeSize := cgExtendedSize; cgString: TypeSize := cgByteSize; cgVoid,ccPointer: TypeSize := cgLongSize; end; {case} end; {TypeSize} end. \ No newline at end of file diff --git a/DAG.pas b/DAG.pas new file mode 100755 index 0000000..95e0699 --- /dev/null +++ b/DAG.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { DAG Creation } { } { Places intermediate codes into DAGs and trees. } { } {---------------------------------------------------------------} unit DAG; interface {$segment 'cg'} {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC, Gen; {---------------------------------------------------------------} procedure DAG (code: icptr); { place an op code in a DAG or tree } { } { parameters: } { code - opcode } {---------------------------------------------------------------} implementation var c_ind: iclist; {vars that can be changed by indirect stores} maxLoc: integer; {max local label number used by compiler} memberOp: icptr; {operation found by Member} optimizations: array[pcodes] of integer; {starting indexes into peeptable} peepTablesInitialized: boolean; {have the peephole tables been initialized?} rescan: boolean; {redo the optimization pass?} {-- External unsigned math routines; imported from Expression.pas --} function udiv (x,y: longint): longint; extern; function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; {---------------------------------------------------------------} function CodesMatch (op1, op2: icptr; exact: boolean): boolean; { Check to see if the trees op1 and op2 are equivalent } { } { parameters: } { op1, op2 - trees to check } { exact - is an exact match of operands required? } { } { Returns: True if trees are equivalent, else false. } function LongStrCmp (s1, s2: longStringPtr): boolean; { Are the strings s1 amd s2 equal? } { } { parameters: } { s1, s2 - strings to compare } { } { Returns: True if the strings are equal, else false } label 1; var i: integer; {loop/index variable} begin {LongStrCmp} LongStrCmp := false; if s1^.length = s2^.length then begin for i := 1 to s1^.length do if s1^.str[i] <> s2^.str[i] then goto 1; LongStrCmp := true; end; {if} 1: end; {LongStrCmp} function OpsEqual (op1, op2: icptr): boolean; { See if the operands are equal } { } { parameters: } { op1, op2 - operations to check } { } { Returns: True if the operands are equivalent, else } { false. } var result: boolean; {temp result} begin {OpsEqual} result := false; case op1^.opcode of pc_cup, pc_cui, pc_tl1, pc_bno: {this rule prevents optimizations from removing sensitive operations} ; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bor, pc_blr, pc_bxr, pc_blx, pc_equ, pc_neq, pc_ior, pc_lor, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; if not result then if op1^.left = op2^.right then if op1^.right = op2^.left then result := true; if not result then if not exact then if CodesMatch(op1^.left, op2^.left, false) then if CodesMatch(op1^.right, op2^.right, false) then result := true; if not result then if not exact then if CodesMatch(op1^.left, op2^.right, false) then if CodesMatch(op1^.right, op2^.left, false) then result := true; end; otherwise: begin if op1^.left = op2^.left then if op1^.right = op2^.right then result := true; if not result then if not exact then if CodesMatch(op1^.left, op2^.left, false) then if CodesMatch(op1^.right, op2^.right, false) then result := true; end; end; {case} OpsEqual := result; end; {OpsEqual} begin {CodesMatch} CodesMatch := false; if op1 = op2 then CodesMatch := true else if (op1 <> nil) and (op2 <> nil) then if op1^.opcode = op2^.opcode then if op1^.q = op2^.q then if op1^.r = op2^.r then if op1^.s = op2^.s then if op1^.lab^ = op2^.lab^ then if OpsEqual(op1, op2) then if op1^.optype = op2^.optype then case op1^.optype of cgByte, cgUByte, cgWord, cgUWord: if op1^.opnd = op2^.opnd then if op1^.llab = op2^.llab then if op1^.slab = op2^.slab then CodesMatch := true; cgLong, cgULong: if op1^.lval = op2^.lval then CodesMatch := true; cgReal, cgDouble, cgComp, cgExtended: if op1^.rval = op2^.rval then CodesMatch := true; cgString: CodesMatch := LongStrCmp(op1^.str, op2^.str); cgVoid, ccPointer: if op1^.pval = op2^.pval then CodesMatch := LongStrCmp(op1^.str, op2^.str); end; {case} end; {CodesMatch} {- Peephole Optimization ---------------------------------------} function Base (val: longint): integer; { Assuming val is a power of 2, find ln(val) base 2 } { } { parameters: } { val - value for which to find the base } { } { Returns: ln(val), base 2 } var i: integer; {base counter} begin {Base} i := 0; while not odd(val) do begin val := val >> 1; i := i+1; end; {while} Base := i; end; {Base} procedure BinOps (var op1, op2: icptr); { Make sure the operands are of the same type } { } { parameters: } { op1, op2: two pc_ldc operands } var opt1, opt2: baseTypeEnum; {temp operand types} begin {BinOps} opt1 := op1^.optype; opt2 := op2^.optype; if opt1 = cgByte then begin op1^.optype := cgWord; opt1 := cgWord; end {if} else if opt1 = cgUByte then begin op1^.optype := cgUWord; opt1 := cgUWord; end {else if} else if opt1 in [cgReal, cgDouble, cgComp] then begin op1^.optype := cgExtended; opt1 := cgExtended; end; {else if} if opt2 = cgByte then begin op2^.optype := cgWord; opt2 := cgWord; end {if} else if opt2 = cgUByte then begin op2^.optype := cgUWord; opt2 := cgUWord; end {else if} else if opt2 in [cgReal, cgDouble, cgComp] then begin op2^.optype := cgExtended; opt2 := cgExtended; end; {else if} if opt1 <> opt2 then begin case opt1 of cgWord: case opt2 of cgUWord: op1^.optype := cgUWord; cgLong, cgULong: begin op1^.lval := op1^.q; op1^.optype := opt2; end; cgExtended: begin op1^.rval := op1^.q; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgUWord: case opt2 of cgWord: op2^.optype := cgUWord; cgLong, cgULong: begin op1^.lval := ord4(op1^.q) & $0000FFFF; op1^.optype := opt2; end; cgExtended: begin op1^.rval := ord4(op1^.q) & $0000FFFF; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgLong: case opt2 of cgWord: begin op2^.lval := op2^.q; op2^.optype := cgLong; end; cgUWord: begin op2^.lval := ord4(op2^.q) & $0000FFFF; op2^.optype := cgLong; end; cgULong: op1^.optype := cgULong; cgExtended: begin op1^.rval := op1^.lval; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgULong: case opt2 of cgWord: begin op2^.lval := op2^.q; op2^.optype := cgLong; end; cgUWord: begin op2^.lval := ord4(op2^.q) & $0000FFFF; op2^.optype := cgLong; end; cgLong: op2^.optype := cgULong; cgExtended: begin op1^.rval := op1^.lval; if op1^.rval < 0.0 then op1^.rval := 4294967296.0 + op1^.rval; op1^.optype := cgExtended; end; otherwise: ; end; {case} cgExtended: begin case opt2 of cgWord: op2^.rval := op2^.q; cgUWord: op2^.rval := ord4(op2^.q) & $0000FFFF; cgLong: op2^.rval := op2^.lval; cgULong: begin op2^.rval := op2^.lval; if op2^.rval < 0.0 then op2^.rval := 4294967296.0 + op2^.rval; end; otherwise: ; end; {case} op2^.optype := cgExtended; end; otherwise: ; end; {case} end; {if} end; {BinOps} procedure CheckLabels; { remove unused dc_lab labels } var lop: icptr; {predecessor of op} op: icptr; {used to trace the opcode list} function Used (lab: integer): boolean; { see if a label is used } { } { parameters: } { lab - label number to check } { } { Returns: True if the label is used, else false. } var found: boolean; {was the label found?} op: icptr; {used to trace the opcode list} begin {Used} found := false; op := DAGhead; while (not found) and (op <> nil) do begin if op^.opcode in [pc_add, pc_fjp, pc_tjp, pc_ujp] then found := op^.q = lab else if op^.opcode = pc_nat then found := true; op := op^.next; end; {while} Used := found; end; {Used} begin {CheckLabels} op := DAGhead; while op^.next <> nil do begin lop := op; op := op^.next; if op^.opcode = dc_lab then if not Used(op^.q) then begin lop^.next := op^.next; op := lop; rescan := true; end; {if} end; {while} end; {CheckLabels} procedure RemoveDeadCode (op: icptr); { remove dead code following an unconditional branch } { } { parameters: } { op - unconditional branch opcode } begin {RemoveDeadCode} while not (op^.next^.opcode in [dc_lab, dc_enp, dc_cns, dc_glb, dc_dst, dc_str, dc_pin, pc_ent, dc_loc, dc_prm, dc_sym]) do begin op^.next := op^.next^.next; rescan := true; end; {while} end; {RemoveDeadCode} function NoFunctions (op: icptr): boolean; { are there any function calls? } { } { parameters: } { op - operation tree to search } { } { returns: True if there are no pc_cup or pc_cui operations } { in the tree, else false. } begin {NoFunctions} if op = nil then NoFunctions := true else if op^.opcode in [pc_cup,pc_cui,pc_tl1] then NoFunctions := false else NoFunctions := NoFunctions(op^.left) or NoFunctions(op^.right); end; {NoFunctions} function OneBit (val: longint): boolean; { See if there is exactly one bit set in val } { } { parameters: } { val - value to check } { } { Returns: True if exactly one bit is set, else false } begin {OneBit} if val = 0 then OneBit := false else begin while not odd(val) do val := val >> 1; OneBit := val = 1; end; {else} end; {OneBit} procedure PeepHoleOptimization (var opv: icptr); { do peephole optimization on a list of opcodes } { } { parameters: } { opv - pointer to the first opcode } { } { Notes: } { 1. Many optimizations assume the children have already } { been optimized. In particular, many optimizations } { depend on pc_ldc operands being on a specific side of } { a child's expression tree. (e.g. pc_fjp and pc_equ) } var done: boolean; {optimization done test} doit: boolean; {should we do the optimization?} lq, lval: longint; {temps for long calculations} op2,op3: icptr; {temp opcodes} op: icptr; {copy of op (for efficiency)} opcode: pcodes; {temp opcode} optype: baseTypeEnum; {temp optype} q: integer; {temp for integer calculations} rval: double; {temp for real calculations} fromtype, totype, firstType: record {for converting numbers to optypes} case boolean of true: (i: integer); false: (optype: baseTypeEnum); end; function SideEffects (op: icptr): boolean; { Check a tree for operations that have side effects } { } { parameters: } { op - tree to check } var result: boolean; {temp result} begin {SideEffects} if (op = nil) or volatile then SideEffects := false else if op^.opcode in [pc_mov,pc_cbf,pc_cop,pc_cpi,pc_cpo,pc_gil,pc_gli,pc_gdl, pc_gld,pc_iil,pc_ili,pc_idl,pc_ild,pc_lil,pc_lli,pc_ldl, pc_lld,pc_sbf,pc_sro,pc_sto,pc_str,pc_cui,pc_cup,pc_tl1] then SideEffects := true else SideEffects := SideEffects(op^.left) or SideEffects(op^.right); end; {SideEffects} procedure JumpOptimizations (op: icptr; newOpcode: pcodes); { handle common code for jump optimizations } { } { parameters: } { op - jump opcode } { newOpcode - opcode to use if the jump sense is reversed } var done: boolean; {optimization done test} topcode: pcodes; {temp opcode} begin {JumpOptimizations} topcode := op^.left^.opcode; if topcode = pc_not then begin op^.left := op^.left^.left; op^.opcode := newOpcode; PeepHoleOptimization(opv); end {else if} else if topcode in [pc_neq,pc_equ] then begin with op^.left^.right^ do if opcode = pc_ldc then if optype in [cgByte,cgUByte,cgWord,cgUWord] then if q = 0 then begin op^.left := op^.left^.left; if topcode = pc_equ then op^.opcode := newOpcode; end; {if} end; {else if} if op^.next^.opcode = dc_lab then if op^.next^.q = op^.q then if not SideEffects(op^.left) then begin rescan := true; opv := op^.next; end; {else if} end; {JumpOptimizations} procedure RealStoreOptimizations (op, opl: icptr); { do strength reductions associated with stores of reals } { } { parameters: } { op - real store to optimize } { opl - load operand for the store operation } var disp: 0..9; {disp to the word to change} same: boolean; {are the operands the same?} op2: icptr; {new opcode} opt: icptr; {temp opcode} cnvrl: record {for stuffing a real in a long space} case boolean of true: (lval: longint); false: (rval: real); end; begin {RealStoreOptimizations} if opl^.opcode = pc_ngr then begin same := false; with opl^.left^ do if op^.opcode = pc_sro then begin if opcode = pc_ldo then if q = op^.q then if optype = op^.optype then if lab^ = op^.lab^ then same := true; end {if} else {if op^.opcode = pc_str then} if opcode = pc_lod then if q = op^.q then if r = op^.r then if optype = op^.optype then same := true; if same then begin case op^.optype of cgReal: disp := 3; cgDouble: disp := 7; cgExtended: disp := 9; cgComp: disp := 11; end; {case} opl^.left^.optype := cgWord; opl^.left^.q := opl^.left^.q + disp; op^.optype := cgWord; op^.q := op^.q + disp; op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.opcode := pc_ldc; op2^.optype := cgWord; op2^.q := $0080; opl^.right := op2; opl^.opcode := pc_bxr; end {if} else if op^.optype = cgReal then begin opt := opl^.left; if opt^.opcode in [pc_ind,pc_ldo,pc_lod] then if opt^.optype = cgReal then begin opt^.optype := cgLong; op^.optype := cgLong; op2 := pointer(Calloc(sizeof(intermediate_code))); op2^.opcode := pc_ldc; op2^.optype := cgLong; op2^.lval := $80000000; opl^.right := op2; opl^.opcode := pc_blx; end; {if} end; {else if} end {if} else if op^.optype = cgReal then begin if opl^.opcode = pc_ldc then begin cnvrl.rval := opl^.rval; opl^.lval := cnvrl.lval; opl^.optype := cgLong; op^.optype := cgLong; end {if} else if opl^.opcode in [pc_ind,pc_ldo,pc_lod] then if opl^.optype = cgReal then begin opl^.optype := cgLong; op^.optype := cgLong; end; {if} end; {if} end; {RealStoreOptimizations} procedure ReplaceLoads (ldop, stop, tree: icptr); { Replace any pc_lod operations in tree that load from the } { location stored to by the pc_str operation stop by ldop } { } { parameters: } { ldop - operation to replace the pc_lods with } { stop - pc_str operation } { tree - tree to check for pc_lod operations } { } { Notes: ldop must be an instruction, not a tree } begin {ReplaceLoads} if tree^.left <> nil then ReplaceLoads(ldop, stop, tree^.left); if tree^.right <> nil then ReplaceLoads(ldop, stop, tree^.right); if tree^.opcode = pc_lod then if tree^.optype = stop^.optype then if tree^.q = stop^.q then if tree^.r = stop^.r then tree^ := ldop^; end; {ReplaceLoads} procedure ReverseChildren (op: icptr); { reverse the children of a node } { } { parameters: } { op - node for which to reverse the children } var opt: icptr; {temp opcode pointer} begin {ReverseChildren} opt := op^.right; op^.right := op^.left; op^.left := opt; end; {ReverseChildren} procedure ZeroIntermediateCode (op: icptr); { Set all fields in the record to 0, nil, etc. } { } { Parameters: } { op - intermediate code record to clear } begin {ZeroIntermediateCode} op^.q := 0; op^.r := 0; op^.s := 0; op^.lab := nil; op^.next := nil; op^.left := nil; op^.right := nil; op^.optype := cgWord; op^.opnd := 0; op^.llab := 0; op^.slab := 0; end; {ZeroIntermediateCode} begin {PeepHoleOptimization} {if printSymbols then begin write('Optimize: '); WriteCode(opv); end; {debug} op := opv; {copy for efficiency} if op^.left <> nil then {optimize the children} PeepHoleOptimization(op^.left); if op^.right <> nil then PeepHoleOptimization(op^.right); case op^.opcode of {check for optimizations of this node} pc_add: begin {pc_add} if op^.next^.opcode <> pc_add then RemoveDeadCode(op); end; {case pc_add} pc_adi: begin {pc_adi} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.q := op^.left^.q + op^.right^.q; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if q = 0 then opv := op^.left else if q > 0 then begin op^.opcode := pc_inc; op^.q := q; op^.right := nil; end {else if} else {if q < 0 then} begin op^.opcode := pc_dec; op^.q := -q; op^.right := nil; end; {else if} end {if} else if CodesMatch(op^.left, op^.right, false) then begin if NoFunctions(op^.left) then begin ZeroIntermediateCode(op^.right); with op^.right^ do begin opcode := pc_ldc; q := 1; optype := cgWord; end; {with} op^.opcode := pc_shl; PeepHoleOptimization(opv); end; {if} end {else if} else if op^.left^.opcode in [pc_inc,pc_dec] then begin if op^.right^.opcode in [pc_inc,pc_dec] then begin op2 := op^.left; if op2^.opcode = pc_inc then q := op2^.q else q := -op2^.q; if op^.right^.opcode = pc_inc then q := q + op^.right^.q else q := q - op^.right^.q; if q >= 0 then begin op2^.opcode := pc_inc; op2^.q := q; end {if} else begin op2^.opcode := pc_dec; op2^.q := -q; end; {else} op^.left := op^.left^.left; op^.right := op^.right^.left; op2^.left := op; opv := op2; PeepHoleOptimization(opv); end; {if} end; {else if} end; {else} end; {case pc_adi} pc_adl: begin {pc_adl} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.lval := op^.left^.lval + op^.right^.lval; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin lval := op^.right^.lval; if lval = 0 then opv := op^.left else if (lval >= 0) and (lval <= maxint) then begin op^.opcode := pc_inc; op^.optype := cgLong; op^.q := ord(lval); op^.right := nil; end {else if} else if (lval > -maxint) and (lval < 0) then begin op^.opcode := pc_dec; op^.optype := cgLong; op^.q := -ord(lval); op^.right := nil; end; {else if} end {if} else if CodesMatch(op^.left, op^.right, false) then if NoFunctions(op^.left) then begin ZeroIntermediateCode(op^.right); with op^.right^ do begin opcode := pc_ldc; lval := 1; optype := cgLong; end; {with} op^.opcode := pc_sll; end; {if} if op^.right^.opcode in [pc_lao,pc_lda,pc_ixa] then ReverseChildren(op); if op^.left^.opcode in [pc_lao,pc_lda,pc_ixa] then if op^.right^.opcode = pc_sll then begin if op^.right^.right^.opcode = pc_ldc then if (op^.right^.right^.lval & $FFFF8000) = 0 then if op^.right^.left^.opcode = pc_cnv then begin fromtype.i := (op^.right^.left^.q & $00F0) >> 4; if fromType.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin if fromType.optype = cgByte then op^.right^.left^.q := $02 else if fromType.optype = cgUByte then op^.right^.left^.q := $13 else op^.right^.left := op^.right^.left^.left; with op^.right^.right^ do begin lq := lval; lval := 0; q := long(lq).lsw; optype := cgUWord; end; {with} op^.right^.opcode := pc_shl; op^.opcode := pc_ixa; PeepHoleOptimization(opv); end; {if} end; {if} end {if} else if op^.right^.opcode = pc_cnv then begin fromtype.i := (op^.right^.q & $00F0) >> 4; if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin if fromType.optype = cgByte then op^.right^.q := $02 else if fromType.optype = cgUByte then op^.right^.q := $13 else op^.right := op^.right^.left; op^.opcode := pc_ixa; PeepHoleOptimization(opv); end; {if} end; {else if} end; {else} end; {case pc_adl} pc_adr: begin {pc_adr} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.rval := op^.left^.rval + op^.right^.rval; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin if op^.right^.rval = 0.0 then opv := op^.left; end; {if} end; {else} end; {case pc_adr} pc_and: begin {pc_and} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.q <> 0) and (op^.right^.q <> 0)); opv := op^.left; end {if} else begin if op^.right^.q = 0 then if not SideEffects(op^.left) then opv := op^.right; end {else} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.q = 0 then opv := op^.left; end; {case pc_and} pc_bal: begin {pc_bal} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval & op^.right^.lval; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.lval = 0 then opv := op^.right else if op^.right^.lval = -1 then opv := op^.left; end; {else if} end; {case pc_bal} pc_blr: begin {pc_blr} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval | op^.right^.lval; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.lval = -1 then opv := op^.right else if op^.right^.lval = 0 then opv := op^.left; end; {else if} end; {case pc_blr} pc_blx: begin {pc_blx} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval ! op^.right^.lval; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.lval = 0 then opv := op^.left else if op^.right^.lval = -1 then begin op^.opcode := pc_bnl; op^.right := nil; end; {else if} end; {else if} end; {case pc_blx} pc_bnd: begin {pc_bnd} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q & op^.right^.q; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.q = 0 then opv := op^.right else if op^.right^.q = -1 then opv := op^.left; end; {else if} end; {case pc_bnd} pc_bnl: begin {pc_bnl} if op^.left^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval ! $FFFFFFFF; opv := op^.left; end; {if} end; {case pc_bnl} pc_bno: begin {pc_bno} if op^.left^.opcode = pc_str then if op^.left^.left^.opcode in [pc_lda,pc_lao] then begin ReplaceLoads(op^.left^.left, op^.left, op^.right); opv := op^.right; end; {if} end; {case pc_bno} pc_bnt: begin {pc_bnt} if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q ! $FFFF; opv := op^.left; end; {if} end; {case pc_bnt} pc_bor: begin {pc_bor} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q | op^.right^.q; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.q = -1 then opv := op^.right else if op^.right^.q = 0 then opv := op^.left; end; {else if} end; {case pc_bor} pc_bxr: begin {pc_bxr} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.left^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q ! op^.right^.q; opv := op^.left; end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.q = 0 then opv := op^.left else if op^.right^.q = -1 then begin op^.opcode := pc_bnt; op^.right := nil; end; {else if} end; {else if} end; {case pc_bxr} pc_cnv: begin {pc_cnv} fromtype.i := (op^.q & $00F0) >> 4; totype.i := op^.q & $000F; if op^.left^.opcode = pc_ldc then begin case fromtype.optype of cgByte,cgWord: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: ; cgLong,cgULong: begin lval := op^.left^.q; op^.left^.q := 0; op^.left^.lval := lval; end; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.q; op^.left^.q := 0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgUByte,cgUWord: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: ; cgLong,cgULong: begin lval := ord4(op^.left^.q) & $0000FFFF; op^.left^.q := 0; op^.left^.lval := lval; end; cgReal,cgDouble,cgComp,cgExtended: begin rval := ord4(op^.left^.q) & $0000FFFF; op^.left^.q := 0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgLong: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: begin q := long(op^.left^.lval).lsw; op^.left^.lval := 0; op^.left^.q := q; end; cgLong, cgULong: ; cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.lval; op^.left^.lval := 0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgULong: case totype.optype of cgByte,cgUByte,cgWord,cgUWord: begin q := long(op^.left^.lval).lsw; op^.left^.lval := 0; op^.left^.q := q; end; cgLong, cgULong: ; cgReal,cgDouble,cgComp,cgExtended: begin lval := op^.left^.lval; op^.left^.lval := 0; if lval >= 0 then rval := lval else rval := (lval & $7FFFFFFF) + 2147483648.0; op^.left^.rval := rval; end; otherwise: ; end; {case} cgReal,cgDouble,cgComp,cgExtended: begin rval := op^.left^.rval; case totype.optype of cgByte: begin if rval < -128.0 then q := -128 else if rval > 127.0 then q := 127 else q := trunc(rval); op^.left^.rval := 0.0; op^.left^.q := q; end; cgUByte: begin if rval < 0.0 then q := 0 else if rval > 255.0 then q := 255 else q := trunc(rval); op^.left^.rval := 0.0; op^.left^.q := q; end; cgWord: begin if rval < -32768.0 then lval := -32768 else if rval > 32767.0 then lval := 32767 else lval := trunc(rval); op^.left^.rval := 0.0; op^.left^.q := long(lval).lsw; end; cgUWord: begin if rval < 0.0 then lval := 0 else if rval > 65535.0 then lval := 65535 else begin rval := trunc4(rval); lval := round4(rval); end; {else} op^.left^.rval := 0.0; op^.left^.q := long(lval).lsw; end; cgLong,cgULong: begin rval := op^.left^.rval; if totype.optype = cgULong then begin if rval < 0 then rval := 0 else if rval > 2147483647.0 then rval := rval - 4294967296.0 end; {if} if rval < -2147483648.0 then lval := $80000000 else if rval > 2147483647.0 then lval := 2147483647 else begin rval := trunc4(rval); lval := round4(rval); end; {else} op^.left^.rval := 0.0; op^.left^.lval := lval; end; cgReal,cgDouble,cgComp,cgExtended: ; otherwise: ; end; end; {case} otherwise: ; end; {case} if fromtype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, cgComp,cgExtended] then if totype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong,cgReal,cgDouble, cgComp,cgExtended] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} end {if} else if op^.left^.opcode = pc_cnv then begin doit := false; firsttype.i := (op^.q & $00F0) >> 4; if fromType.optype in [cgReal,cgDouble,cgComp,cgExtended] then begin if toType.optype in [cgReal,cgDouble,cgComp,cgExtended] then doit := true; end {if} else begin if firstType.optype in [cgByte,cgWord,cgLong] then if fromType.optype in [cgByte,cgWord,cgLong] then if toType.optype in [cgByte,cgWord,cgLong] then doit := true; if firstType.optype in [cgUByte,cgUWord,cgULong] then if fromType.optype in [cgUByte,cgUWord,cgULong] then if toType.optype in [cgUByte,cgUWord,cgLong] then doit := true; if TypeSize(firstType.optype) = TypeSize(fromType.optype) then if TypeSize(firstType.optype) = TypeSize(toType.optype) then doit := true; end; {else} if doit then begin op^.q := (op^.left^.q & $00F0) | (op^.q & $000F); op^.left := op^.left^.left; PeepHoleOptimization(opv); end; {if} end {else if} else if op^.left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin if fromtype.optype in [cgWord,cgUWord] then if totype.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} if fromtype.optype in [cgLong,cgULong] then if totype.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong] then begin op^.left^.optype := totype.optype; opv := op^.left; end; {if} end {else if} else if op^.q in [$40,$41,$50,$51] then begin {any long type to byte type} with op^.left^ do if opcode = pc_bal then if right^.opcode = pc_ldc then if right^.lval = 255 then begin op^.left := op^.left^.left; PeepHoleOptimization(opv); end; {if} with op^.left^ do if opcode in [pc_slr,pc_vsr] then if right^.opcode = pc_ldc then if left^.opcode in [pc_lod,pc_ldo,pc_ind] then begin lq := right^.lval; if long(lq).msw = 0 then if long(lq).lsw in [8,16,24] then begin lq := lq div 8; left^.q := left^.q + long(lq).lsw; op^.left := left; PeepHoleOptimization(opv); end; {if} end; {if} end; {else if} end; {case pc_cnv} pc_dec: begin {pc_dec} if op^.q = 0 then opv := op^.left else begin opcode := op^.left^.opcode; if opcode = pc_dec then begin if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin op^.q := op^.q + op^.left^.q; op^.left := op^.left^.left; end; {if} end {if} else if opcode = pc_inc then begin q := op^.q - op^.left^.q; if q < 0 then begin q := -q; op^.opcode := pc_inc; end; {if} op^.q := q; op^.left := op^.left^.left; PeepHoleOptimization(opv); end {else if} else if opcode = pc_ldc then begin if op^.optype in [cgLong, cgULong] then begin op^.left^.lval := op^.left^.lval - op^.q; opv := op^.left; end {if} else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin op^.left^.q := op^.left^.q - op^.q; opv := op^.left; end; {else if} end; {else if} end; {else} end; {case pc_dec} pc_dvi: begin {pc_dvi} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin if op^.right^.q <> 0 then begin op^.left^.q := op^.left^.q div op^.right^.q; opv := op^.left; end; {if} end {if} else if op^.right^.q = 1 then opv := op^.left; end; {if} end; {case pc_dvi} pc_dvl: begin {pc_dvl} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin if op^.right^.lval <> 0 then begin op^.left^.lval := op^.left^.lval div op^.right^.lval; opv := op^.left; end; {if} end {if} else if op^.right^.lval = 1 then opv := op^.left; end; {if} end; {case pc_dvl} pc_dvr: begin {pc_dvr} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin if op^.right^.rval <> 0.0 then begin op^.left^.rval := op^.left^.rval/op^.right^.rval; opv := op^.left; end; {if} end {if} else if op^.right^.rval = 1.0 then opv := op^.left; end; {if} end; {case pc_dvr} pc_equ: begin {pc_equ} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin BinOps(op^.left, op^.right); case op^.left^.optype of cgByte,cgUByte,cgWord,cgUWord: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.q = op^.right^.q); op^.left := nil; op^.right := nil; end; cgLong,cgULong: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.lval = op^.right^.lval); op^.left := nil; op^.right := nil; end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval = op^.right^.rval); op^.left := nil; op^.right := nil; end; cgVoid,ccPointer: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.pval = op^.right^.pval); op^.left := nil; op^.right := nil; end; end; {case} end {if} else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin if op^.right^.q <> 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end {else if} else if op^.right^.optype in [cgLong, cgULong] then begin if op^.right^.lval <> 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end; {else if} end; {if} end; {case pc_equ} pc_fjp: begin {pc_fjp} opcode := op^.left^.opcode; if opcode = pc_ldc then begin if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin if op^.left^.q <> 0 then begin opv := op^.next; rescan := true; end {if} else begin op^.opcode := pc_ujp; op^.left := nil; PeepHoleOptimization(opv); end; {else} end {if} end {if} else if opcode = pc_and then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_fjp; op2^.q := op^.q; PeepHoleOptimization(opv); end {else if} else if opcode = pc_ior then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_fjp; op2^.q := op^.q; op^.opcode := pc_tjp; op3 := pointer(Calloc(sizeof(intermediate_code))); op3^.opcode := dc_lab; op3^.optype := cgWord; op3^.q := GenLabel; op3^.next := op2^.next; op2^.next := op3; op^.q := op3^.q; PeepHoleOptimization(opv); end {else if} else JumpOptimizations(op, pc_tjp); end; {case pc_fjp} pc_inc: begin {pc_inc} if op^.q = 0 then opv := op^.left else begin opcode := op^.left^.opcode; if opcode = pc_inc then begin if ord4(op^.left^.q) + ord4(op^.q) < ord4(maxint) then begin op^.q := op^.q + op^.left^.q; op^.left := op^.left^.left; end; {if} end {if} else if opcode = pc_dec then begin q := op^.q - op^.left^.q; if q < 0 then begin q := -q; op^.opcode := pc_dec; end; {if} op^.q := q; op^.left := op^.left^.left; PeepHoleOptimization(opv); end {else if} else if opcode = pc_ldc then begin if op^.optype in [cgLong, cgULong] then begin op^.left^.lval := op^.left^.lval + op^.q; opv := op^.left; end {if} else if op^.optype in [cgUByte, cgByte, cgUWord, cgWord] then begin op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end; {else if} end {else if} else if opcode in [pc_lao,pc_lda] then begin op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end; {else if} end; {else} end; {case pc_inc} pc_ind: begin {pc_ind} opcode := op^.left^.opcode; if opcode = pc_lda then begin op^.left^.opcode := pc_lod; op^.left^.optype := op^.optype; op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end {if} else if opcode = pc_lao then begin op^.left^.opcode := pc_ldo; op^.left^.optype := op^.optype; op^.left^.q := op^.left^.q + op^.q; opv := op^.left; end; {else if} end; {case pc_ind} pc_ior: begin {pc_ior} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.q <> 0) or (op^.right^.q <> 0)); opv := op^.left; end {if} else begin if op^.right^.q <> 0 then begin if not SideEffects(op^.left) then begin op^.right^.q := 1; opv := op^.right; end; {if} end {if} else op^.opcode := pc_neq; end {if} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.q <> 0 then begin op^.left^.q := 1; opv := op^.left; end; {if} end; {case pc_ior} pc_ixa: begin {pc_ixa} if op^.right^.opcode = pc_ldc then begin optype := op^.right^.optype; if optype in [cgUByte, cgByte, cgUWord, cgWord] then begin lval := op^.right^.q; if optype = cgUByte then lval := lval & $000000FF else if optype = cgUWord then lval := lval & $0000FFFF; done := false; if op^.left^.opcode in [pc_lao, pc_lda] then begin lq := op^.left^.q + lval; if (lq >= 0) and (lq < maxint) then begin done := true; op^.left^.q := ord(lq); opv := op^.left; end; {if} end; {if} if not done then begin op^.right^.lval := lval; op^.right^.optype := cgLong; op^.opcode := pc_adl; PeepHoleOptimization(opv); end; {if} end; {if} end {if} else if op^.left^.opcode = pc_lao then begin if op^.right^.opcode = pc_inc then begin lq := ord4(op^.right^.q) + ord4(op^.left^.q); if lq < maxint then begin op^.left^.q := ord(lq); op^.right := op^.right^.left; end; {if} PeepHoleOptimization(opv); end; {if} end {else if} else if op^.left^.opcode = pc_ixa then begin op2 := op^.left; op^.left := op^.left^.left; op2^.left := op^.right; op2^.opcode := pc_adi; op^.right := op2; end; {else if} end; {case pc_ixa} pc_leq: begin {pc_leq} if op^.optype in [cgWord,cgUWord] then if op^.right^.opcode = pc_ldc then if op^.right^.q < maxint then begin op^.right^.q := op^.right^.q + 1; op^.opcode := pc_les; end; {if} end; {case pc_lnm} pc_lnd: begin {pc_lnd} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.lval <> 0) and (op^.right^.lval <> 0)); op^.left^.optype := cgWord; opv := op^.left; end {if} else begin if op^.right^.lval = 0 then begin if not SideEffects(op^.left) then begin with op^.right^ do begin lval := 0; optype := cgWord; q := 0; end; {with} opv := op^.right; end; {if} end {if} else op^.opcode := pc_neq; end; {if} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.lval = 0 then begin with op^.left^ do begin lval := 0; optype := cgWord; q := 0; end; {with} opv := op^.left; end; {if} end; {case pc_lnd} pc_lnm: begin {pc_lnm} if op^.next^.opcode = pc_lnm then begin opv := op^.next; rescan := true; end; {if} end; {case pc_lnm} pc_lor: begin {pc_lor} if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin op^.left^.q := ord((op^.left^.lval <> 0) or (op^.right^.lval <> 0)); optype := cgWord; opv := op^.left; end {if} else begin if op^.right^.lval <> 0 then begin if not SideEffects(op^.left) then begin op^.right^.lval := 0; op^.right^.q := 1; op^.right^.optype := cgWord; opv := op^.right; end; {if} end {if} else begin op^.opcode := pc_neq; op^.optype := cgLong; end; {else} end; {if} end {if} else if op^.left^.opcode = pc_ldc then if op^.left^.lval <> 0 then begin op^.left^.lval := 0; op^.left^.q := 1; op^.left^.optype := cgWord; opv := op^.left; end; {if} end; {case pc_lor} pc_mdl: begin {pc_mdl} if op^.right^.opcode = pc_ldc then if op^.left^.opcode = pc_ldc then if op^.right^.lval <> 0 then begin op^.left^.lval := op^.left^.lval mod op^.right^.lval; opv := op^.left; end; {if} end; {case pc_mdl} pc_mod: begin {pc_mod} if op^.right^.opcode = pc_ldc then if op^.left^.opcode = pc_ldc then if op^.right^.q <> 0 then begin op^.left^.q := op^.left^.q mod op^.right^.q; opv := op^.left; end; {if} end; {case pc_mod} pc_mpi, pc_umi: begin {pc_mpi, pc_umi} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin if op^.opcode = pc_mpi then op^.left^.q := op^.left^.q*op^.right^.q else {if op^.opcode = pc_umi then} begin lval := umul(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF); op^.left^.q := long(lval).lsw; end; {else} opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if q = 1 then opv := op^.left else if q = 0 then begin if NoFunctions(op^.left) then opv := op^.right; end {else if} else if (q = -1) and (op^.opcode = pc_mpi) then begin op^.opcode := pc_ngi; op^.right := nil; end {else if} else if OneBit(q) then begin op^.right^.q := Base(q); op^.opcode := pc_shl; PeepHoleOptimization(opv); end; {else if} end; {if} end; {else} end; {case pc_mpi, pc_umi} pc_mpl, pc_uml: begin {pc_mpl, pc_uml} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin if op^.opcode = pc_mpl then op^.left^.lval := op^.left^.lval*op^.right^.lval else {if op^.opcode = pc_uml then} op^.left^.lval := umul(op^.left^.lval, op^.right^.lval); opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin lval := op^.right^.lval; if lval = 1 then opv := op^.left else if lval = 0 then begin if NoFunctions(op^.left) then opv := op^.right; end {else if} else if (lval = -1) and (op^.opcode = pc_mpl) then begin op^.opcode := pc_ngl; op^.right := nil; end {else if} else if OneBit(lval) then begin op^.right^.lval := Base(lval); op^.opcode := pc_sll; end; {else if} end; {if} end; {else} end; {case pc_mpl, pc_uml} pc_mpr: begin {pc_mpr} if (op^.right^.opcode = pc_ldc) and (op^.left^.opcode = pc_ldc) then begin op^.left^.rval := op^.left^.rval*op^.right^.rval; opv := op^.left; end {if} else begin if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin rval := op^.right^.rval; if rval = 1.0 then opv := op^.left else if rval = 0.0 then if NoFunctions(op^.left) then opv := op^.right; end; {if} end; {else} end; {case pc_mpr} pc_neq: begin {pc_neq} if op^.left^.opcode = pc_ldc then ReverseChildren(op); if op^.right^.opcode = pc_ldc then begin if op^.left^.opcode = pc_ldc then begin BinOps(op^.left, op^.right); case op^.left^.optype of cgByte,cgUByte,cgWord,cgUWord: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.q <> op^.right^.q); op^.left := nil; op^.right := nil; end; cgLong,cgULong: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.lval <> op^.right^.lval); op^.left := nil; op^.right := nil; end; cgReal,cgDouble,cgComp,cgExtended: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.rval <> op^.right^.rval); op^.left := nil; op^.right := nil; end; cgVoid,ccPointer: begin op^.opcode := pc_ldc; op^.q := ord(op^.left^.pval <> op^.right^.pval); op^.left := nil; op^.right := nil; end; end; {case} end {if} else if op^.right^.optype in [cgByte, cgUByte, cgWord, cgUWord] then begin if op^.right^.q = 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end {else if} else if op^.right^.optype in [cgLong, cgULong] then begin if op^.right^.lval = 0 then if op^.left^.opcode in [pc_and,pc_ior,pc_neq,pc_equ,pc_geq,pc_leq,pc_les,pc_grt] then begin opv := op^.left; opv^.next := op^.next; end; {if} end; {else if} end; {if} end; {case pc_neq} pc_ngi: begin {pc_ngi} if op^.left^.opcode = pc_ldc then begin op^.left^.q := -op^.left^.q; opv := op^.left; end; {if} end; {case pc_ngi} pc_ngl: begin {pc_ngl} if op^.left^.opcode = pc_ldc then begin op^.left^.lval := -op^.left^.lval; opv := op^.left; end; {if} end; {case pc_ngl} pc_ngr: begin {pc_ngr} if op^.left^.opcode = pc_ldc then begin op^.left^.rval := -op^.left^.rval; opv := op^.left; end; {if} end; {case pc_ngr} pc_not: begin {pc_not} opcode := op^.left^.opcode; if opcode = pc_ldc then begin if op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin op^.left^.q := ord(op^.left^.q = 0); opv := op^.left; end {if} else if op^.left^.optype in [cgLong,cgULong] then begin q := ord(op^.left^.lval = 0); lval := 0; op^.left^.q := q; op^.left^.optype := cgWord; opv := op^.left; end; {else if} end {if} else if opcode = pc_equ then begin op^.left^.opcode := pc_neq; opv := op^.left; end {else if} else if opcode = pc_neq then begin op^.left^.opcode := pc_equ; opv := op^.left; end {else if} else if opcode = pc_geq then begin op^.left^.opcode := pc_les; opv := op^.left; end {else if} else if opcode = pc_grt then begin op^.left^.opcode := pc_leq; opv := op^.left; end {else if} else if opcode = pc_les then begin op^.left^.opcode := pc_geq; opv := op^.left; end {else if} else if opcode = pc_leq then begin op^.left^.opcode := pc_grt; opv := op^.left; end; {else if} end; {case pc_not} pc_pop: begin {pc_pop} if op^.left^.opcode = pc_cnv then op^.left := op^.left^.left; opcode := op^.left^.opcode; if opcode = pc_cop then begin op^.left^.opcode := pc_str; opv := op^.left; opv^.next := op^.next; PeepHoleOptimization(opv); end {if} else if opcode = pc_cpi then begin op^.left^.opcode := pc_sto; opv := op^.left; opv^.next := op^.next; PeepHoleOptimization(opv); end {else if} else if opcode = pc_cbf then begin op^.left^.opcode := pc_sbf; opv := op^.left; opv^.next := op^.next; end {else if} else if opcode = pc_cpo then begin op^.left^.opcode := pc_sro; opv := op^.left; opv^.next := op^.next; PeepHoleOptimization(opv); end {else if} else if opcode in [pc_inc,pc_dec] then op^.left := op^.left^.left; end; {case pc_pop} pc_ret: begin {pc_ret} RemoveDeadCode(op); end; {case pc_ret} pc_sbi: begin {pc_sbi} if op^.left^.opcode = pc_ldc then begin if op^.right^.opcode = pc_ldc then begin op^.left^.q := op^.left^.q - op^.right^.q; opv := op^.left; end {if} else if op^.left^.q = 0 then begin op^.opcode := pc_ngi; op^.left := op^.right; op^.right := nil; end; {else if} end {if} else if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if q = 0 then opv := op^.left else if (q > 0) then begin op^.opcode := pc_dec; op^.q := q; op^.right := nil; end {else if} else {if q < 0) then} begin op^.opcode := pc_inc; op^.q := -q; op^.right := nil; end; {else if} end {if} else if op^.left^.opcode in [pc_inc,pc_dec] then if op^.right^.opcode in [pc_inc,pc_dec] then begin op2 := op^.left; if op^.left^.opcode = pc_inc then q := op^.left^.q else q := -op^.left^.q; if op^.right^.opcode = pc_inc then q := q - op^.right^.q else q := q + op^.right^.q; if q >= 0 then begin op2^.opcode := pc_inc; op2^.q := q; end {if} else begin op2^.opcode := pc_dec; op2^.q := -q; end; {else} op^.left := op^.left^.left; op^.right := op^.right^.left; op2^.left := op; opv := op2; PeepHoleOptimization(opv); end; {if} end; {case pc_sbi} pc_sbl: begin {pc_sbl} if op^.left^.opcode = pc_ldc then begin if op^.right^.opcode = pc_ldc then begin op^.left^.lval := op^.left^.lval - op^.right^.lval; opv := op^.left; end {if} else if op^.left^.lval = 0 then begin op^.opcode := pc_ngl; op^.left := op^.right; op^.right := nil; end; {else if} end {if} else if op^.right^.opcode = pc_ldc then begin lval := op^.right^.lval; if lval = 0 then opv := op^.left else if (lval > 0) and (lval <= maxint) then begin op^.opcode := pc_dec; op^.q := ord(lval); op^.right := nil; op^.optype := cgLong; end {else if} else if (lval > -maxint) and (lval < 0) then begin op^.opcode := pc_inc; op^.q := -ord(lval); op^.right := nil; op^.optype := cgLong; end; {else if} end; {if} end; {case pc_sbl} pc_sbr: begin {pc_sbr} if op^.left^.opcode = pc_ldc then begin if op^.right^.opcode = pc_ldc then begin op^.left^.rval := op^.left^.rval - op^.right^.rval; opv := op^.left; end {if} else if op^.left^.rval = 0.0 then begin op^.opcode := pc_ngr; op^.left := op^.right; op^.right := nil; end; {else if} end {if} else if op^.right^.opcode = pc_ldc then begin if op^.right^.rval = 0.0 then opv := op^.left; end; {if} end; {case pc_sbr} pc_shl: begin {pc_shl} if op^.right^.opcode = pc_ldc then begin opcode := op^.left^.opcode; if opcode = pc_shl then begin if op^.left^.right^.opcode = pc_ldc then begin op^.right^.q := op^.right^.q + op^.left^.right^.q; op^.left := op^.left^.left; end; {if} end {if} else if opcode = pc_inc then begin op2 := op^.left; op^.left := op2^.left; op2^.q := op2^.q << op^.right^.q; op2^.left := op; opv := op2; PeepHoleOptimization(op2^.left); end; {else if} end; {if} end; {case pc_shl} pc_sro, pc_str: begin {pc_sro, pc_str} if op^.optype in [cgReal,cgDouble,cgExtended] then RealStoreOptimizations(op, op^.left); end; {case pc_sro, pc_str} pc_sto: begin {pc_sto} if op^.optype in [cgReal,cgDouble,cgExtended] then RealStoreOptimizations(op, op^.right); if op^.left^.opcode = pc_lao then begin op^.q := op^.left^.q; op^.lab := op^.left^.lab; op^.opcode := pc_sro; op^.left := op^.right; op^.right := nil; end {if} else if op^.left^.opcode = pc_lda then begin op^.q := op^.left^.q; op^.r := op^.left^.r; op^.opcode := pc_str; op^.left := op^.right; op^.right := nil; end; {if} end; {case pc_sto} pc_tjp: begin {pc_tjp} opcode := op^.left^.opcode; if opcode = pc_ldc then begin if op^.left^.optype in [cgByte, cgUByte, cgWord, cgUWord] then if op^.left^.q = 0 then begin opv := op^.next; rescan := true; end {if} else begin op^.opcode := pc_ujp; op^.left := nil; PeepHoleOptimization(opv); end; {else} end {if} else if opcode = pc_ior then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_tjp; op2^.q := op^.q; PeepHoleOptimization(opv); end {else if} else if opcode = pc_and then begin op2 := op^.left; op2^.next := op^.next; op^.next := op2; op^.left := op2^.left; op2^.left := op2^.right; op2^.right := nil; op2^.opcode := pc_tjp; op2^.q := op^.q; op^.opcode := pc_fjp; op3 := pointer(Calloc(sizeof(intermediate_code))); op3^.opcode := dc_lab; op3^.optype := cgWord; op3^.q := GenLabel; op3^.next := op2^.next; op2^.next := op3; op^.q := op3^.q; PeepHoleOptimization(opv); end {else if} else JumpOptimizations(op, pc_fjp); end; {case pc_tjp} pc_tri: begin {pc_tri} opcode := op^.left^.opcode; if opcode = pc_not then begin ReverseChildren(op^.right); op^.left := op^.left^.left; PeepHoleOptimization(opv); end {if} else if opcode in [pc_equ, pc_neq] then begin with op^.left^.right^ do if opcode = pc_ldc then if optype in [cgByte,cgUByte,cgWord,cgUWord] then if q = 0 then begin if op^.left^.opcode = pc_equ then ReverseChildren(op^.right); op^.left := op^.left^.left; end; {if} end; {else if} end; {case pc_tri} pc_udi: begin {pc_udi} if op^.right^.opcode = pc_ldc then begin q := op^.right^.q; if op^.left^.opcode = pc_ldc then begin if q <> 0 then begin op^.left^.q := ord(udiv(op^.left^.q & $0000FFFF, q & $0000FFFF)); opv := op^.left; end; {if} end {if} else if q = 1 then opv := op^.left else if OneBit(q) then begin op^.right^.q := Base(q); op^.opcode := pc_usr; end; {else if} end; {if} end; {case pc_udi} pc_udl: begin {pc_udl} if op^.right^.opcode = pc_ldc then begin lq := op^.right^.lval; if op^.left^.opcode = pc_ldc then begin if lq <> 0 then begin op^.left^.lval := udiv(op^.left^.lval, lq); opv := op^.left; end; {if} end {if} else if lq = 1 then opv := op^.left else if OneBit(lq) then begin op^.right^.lval := Base(lq); op^.opcode := pc_vsr; end; {else if} end; {if} end; {case pc_udl} pc_uim: begin {pc_uim} if op^.right^.opcode = pc_ldc then if op^.left^.opcode = pc_ldc then if op^.right^.q <> 0 then begin op^.left^.q := ord(umod(op^.left^.q & $0000FFFF, op^.right^.q & $0000FFFF)); opv := op^.left; end; {if} end; {case pc_uim} pc_ujp: begin {pc_ujp} RemoveDeadCode(op); if op^.next^.opcode = dc_lab then begin if op^.q = op^.next^.q then begin opv := op^.next; rescan := true; end {if} else if op^.next^.next^.opcode = dc_lab then if op^.next^.next^.q = op^.q then begin opv := op^.next; rescan := true; end; {if} end; {if} end; {case pc_ujp} pc_ulm: begin {pc_ulm} if op^.right^.opcode = pc_ldc then if op^.left^.opcode = pc_ldc then if op^.right^.lval <> 0 then begin op^.left^.lval := umod(op^.left^.lval, op^.right^.lval); opv := op^.left; end; {if} end; {case pc_ulm} otherwise: ; end; {case} end; {PeepHoleOptimization} {- Common Subexpression Elimination ----------------------------} function MatchLoc (op1, op2: icptr): boolean; { See if two loads, stores or copies refer to the same } { location } { } { parameters: } { op1, op2 - operations to check } { } { Returns: True if they do, false if they don't. } begin {MatchLoc} MatchLoc := false; if (op1^.opcode in [pc_str,pc_cop,pc_lod,pc_lli,pc_lil,pc_lld,pc_ldl,pc_lda]) and (op2^.opcode in [pc_str,pc_cop,pc_lod,pc_lli,pc_lil,pc_lld,pc_ldl,pc_lda]) then begin if op1^.r = op2^.r then MatchLoc := true; end {if} else if (op1^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_gli,pc_gil,pc_gld,pc_gdl,pc_lao]) and (op2^.opcode in [pc_sro,pc_cpo,pc_ldo,pc_gli,pc_gil,pc_gld,pc_gdl,pc_lao]) then if op1^.lab^ = op2^.lab^ then MatchLoc := true; end; {MatchLoc} function Member (op: icptr; list: iclist): boolean; { See if the operand of a load is referenced in a list } { } { parameters: } { op - load to check } { list - list to check } { } { Returns: True if op is in list, else false. } { } { Notes: As a side effect, this subroutine sets memberOp to } { point to any matching member; memberOp is undefined if } { there is no matching member. } begin {Member} Member := false; while list <> nil do begin if MatchLoc(op, list^.op) then begin Member := true; memberOp := list^.op; list := nil; end {if} else list := list^.next; end; {while} end; {Member} function TypeOf (op: icptr): baseTypeEnum; { find the type for the expression tree } { } { parameters: } { op - tree for which to find the type } { } { Returns: base type } begin {TypeOf} case op^.opcode of pc_gil, pc_gli, pc_gdl, pc_gld, pc_iil, pc_ili, pc_idl, pc_ild, pc_ldc, pc_ldo, pc_lil, pc_lli, pc_ldl, pc_lld, pc_lod, pc_dec, pc_inc, pc_ind, pc_lbf, pc_lbu, pc_cop, pc_cbf, pc_cpi, pc_cpo, pc_tri: TypeOf := op^.optype; pc_lad, pc_lao, pc_lca, pc_lda, pc_psh, pc_ixa: TypeOf := cgULong; pc_nop, pc_bnt, pc_ngi, pc_not, pc_adi, pc_and, pc_lnd, pc_bnd, pc_bor, pc_bxr, pc_dvi, pc_equ, pc_geq, pc_grt, pc_leq, pc_les, pc_neq, pc_ior, pc_lor, pc_mod, pc_mpi, pc_sbi, pc_shl, pc_shr: TypeOf := cgWord; pc_udi, pc_uim, pc_umi, pc_usr: TypeOf := cgUWord; pc_bnl, pc_ngl, pc_adl, pc_bal, pc_blr, pc_blx, pc_dvl, pc_mdl, pc_mpl, pc_sbl, pc_sll, pc_slr: TypeOf := cgLong; pc_udl, pc_ulm, pc_uml, pc_vsr: TypeOf := cgULong; pc_ngr, pc_adr, pc_dvr, pc_mpr, pc_sbr: TypeOf := cgExtended; pc_cnn, pc_cnv: TypeOf := baseTypeEnum(op^.q & $000F); pc_stk: TypeOf := TypeOf(op^.left); pc_bno: TypeOf := TypeOf(op^.right); otherwise: Error(cge1); end; {case} end; {TypeOf} procedure CommonSubexpressionElimination; { Remove common subexpressions } type localPtr = ^localRecord; {list of local temp variables} localRecord = record next: localPtr; {next label in list} inUse: boolean; {is this temp already in use?} size: integer; {size of the temp area} lab: integer; {label number} end; var bb: blockPtr; {used to trace basic block lists} done: boolean; {for loop termination tests} op: icptr; {used to trace operation lists, trees} lop: icptr; {predecessor of op} temps: localPtr; {list of temp variables} procedure DisposeTemps; { dispose of the list of temp variables } var tp: localPtr; {temp pointer} begin {DisposeTemps} while temps <> nil do begin tp := temps; temps := tp^.next; dispose(tp); end; {while} end; {DisposeTemps} function GetTemp (bb: blockPtr; size: integer): integer; { Allocate a temp storage location } { } { parameters: } { bb - block in which the temp is allocated } { size - size of the temp } { } { Returns: local label number for the temp } var lab: integer; {label number} loc: icptr; {for dc_loc instruction} tp: localPtr; {used to trace lists, allocate new items} begin {GetTemp} lab := 0; {no label found, yet} tp := temps; {try for a temp of the exact size} while tp <> nil do begin if not tp^.inUse then if tp^.size = size then begin lab := tp^.lab; tp^.inUse := true; tp := nil; end; {if} if tp <> nil then tp := tp^.next; end; {while} if lab = 0 then begin {try for a larger temp} tp := temps; while tp <> nil do begin if not tp^.inUse then if tp^.size > size then begin lab := tp^.lab; tp^.inUse := true; tp := nil; end; {if} if tp <> nil then tp := tp^.next; end; {while} end; {if} if lab = 0 then begin {allocate a new temp} loc := pointer(Calloc(sizeof(intermediate_code))); loc^.opcode := dc_loc; loc^.optype := cgWord; maxLoc := maxLoc + 1; loc^.r := maxLoc; lab := maxLoc; loc^.q := size; if bb^.code = nil then begin loc^.next := nil; bb^.code := loc; end {if} else begin loc^.next := bb^.code^.next; bb^.code^.next := loc; end; {else} new(tp); tp^.next := temps; temps := tp; tp^.inUse := true; tp^.size := loc^.q; tp^.lab := lab; end; {if} GetTemp := lab; {return the temp label number} end; {GetTemp} procedure ResetTemps; { Mark all temps as available } var tp: localPtr; {temp pointer} begin {ResetTemps} tp := temps; while tp <> nil do begin tp^.inUse := false; tp := tp^.next; end; {while} end; {ResetTemps} procedure CheckForBlocks (op: icptr); { Scan a tree for blocked instructions } { } { parameters: } { op - tree to check } { } { Notes: Some code takes less time to execute than saving } { and storing the intermediate value. This subroutine } { identifies such patterns. } function Block (op: icptr): boolean; { See if the pattern should be blocked } { } { parameters: } { op - pattern to check } { } { Returns: True if the pattern should be blocked, else } { false. } var opcode: pcodes; {temp opcode} begin {Block} Block := false; opcode := op^.opcode; if opcode = pc_ixa then begin if op^.left^.opcode in [pc_lao,pc_lca,pc_lda] then Block := true; end {else if} else if opcode = pc_shl then begin if op^.right^.opcode = pc_ldc then if op^.right^.q = 1 then if op^.parents <= 3 then Block := true; end {else if} else if opcode = pc_stk then Block := true else if opcode = pc_cnv then if op^.q & $000F = ord(cgVoid) then Block := true; end; {Block} function Max (a, b: integer): integer; { Return the larger of two integers } { } { parameters: } { a, b - integers to check } { } { Returns: a if a > b, else b } begin {Max} if a > b then Max := a else Max := b; end; {Max} begin {CheckForBlocks} if Block(op) then begin if op^.left <> nil then {handle a blocked instruction} op^.left^.parents := op^.left^.parents + Max(op^.parents - 1, 0); if op^.right <> nil then op^.right^.parents := op^.right^.parents + Max(op^.parents - 1, 0); op^.parents := 1; end; {if} if op^.left <> nil then {check the children} CheckForBlocks(op^.left); if op^.right <> nil then CheckForBlocks(op^.right); end; {CheckForBlocks} procedure CheckTree (var op: icptr; bb: blockPtr); { check the trees used by op for common subexpressions } { } { parameters: } { op - operation to check } { bb - start of the current BASIC block } var op2: icptr; {result from Match calls} op3: icptr; {used to trace the codes in a block} function Match (var op: icptr; tree: icptr): icptr; { Check for matches to op in tree } { } { parameters: } { op - operation to check } { tree - tree to examine for matches } { } { Returns: pointer to matching node or nil if none found } var op2: icptr; {result from recursive Match calls} kill, start, stop: boolean; {used by Scan} skip: boolean; {used to see if children should be scanned} procedure Combine (var op1, op2: icptr); { Op2 is a save or copy of the same value as op1; use a copy } { for op2. } { } { parameters: } { op1 - first copy or save } { op2 - copy or save to optimize } var op3: icptr; {work pointer} begin {Combine} done := false; {force another labeling pass} op3 := op2; {remove op2 from the list} if op3^.opcode in [pc_str,pc_sro] then begin if op3^.opcode = pc_str then op3^.opcode := pc_cop else op3^.opcode := pc_cpo; op2 := op3^.next; op3^.next := nil; end {if} else op2 := op3^.left; op1^.left := op3; {place in the new location} end; {Combine} function SameTree (list, op1, op2: icptr): boolean; { Are op1 and op2 in the same expression tree? } { } { parameters: } { list - list of expression trees } { op1, op2 - operations to check } function InTree (tree, op: icptr): boolean; { See if op is in the tree } { } { parameters: } { tree - expression tree to check } { op - operatio to look for } begin {InTree} if tree = nil then InTree := false else if tree = op then InTree := true else InTree := InTree(tree^.left, op) or InTree(tree^.right, op); end; {InTree} begin {SameTree} SameTree := false; while list <> nil do if InTree(list, op1) then begin SameTree := InTree(list, op2); list := nil; end {if} else list := list^.next; end; {SameTree} procedure Scan (list, op1, op2: icptr); { Check to see if any operation between op1 and op2 kills the } { optimization } { } { parameters: } { list - instruction stream } { op1 - starting operation } { op2 - ending operation } { } { globals: } { kill - set to true if the optimization must be blocked, } { or false if it can be performed } { start - has op1 been found? (initialize to false) } { stop - has kill been set? (initialize to false) } begin {Scan} if not start then {see if it is time to start} if list = op1 then start := true; if list^.left <> nil then {scan the children} Scan(list^.left, op1, op2); if not stop then if list^.right <> nil then Scan(list^.right, op1, op2); if start then {check for a kill or termination} if not stop then if list = op2 then begin kill := false; stop := true; end {if} else if list^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo,pc_lli,pc_lil, pc_lld,pc_ldl,pc_gli,pc_gil,pc_gld,pc_gdl] then begin if MatchLoc(list, op2) then begin kill := true; stop := true; end {if} end {else if} else if list^.opcode in [pc_sto,pc_cpi,pc_iil,pc_ili,pc_idl,pc_ild, pc_cup,pc_cui,pc_tl1] then if Member(op1, c_ind) then begin kill := true; stop := true; end; {if} if not stop then {scan forward in the stream} if list^.next <> nil then Scan(list^.next, op1, op2); end; {Scan} begin {Match} op2 := nil; {check for an exact match} skip := false; if CodesMatch(op, tree, true) then begin if op = tree then op2 := tree else begin start := false; stop := false; Scan(bb^.code, tree, op); if not kill then op2 := tree; end; {else} end {if} {check for stores of a common value} else if op^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then if tree^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo] then if op^.left = tree^.left then begin start := false; stop := false; Scan(bb^.code, tree, op); if not kill then if not SameTree(bb^.code, op, tree) then if (op^.left^.opcode <> pc_ldc) or ((op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and (op^.left^.q <> 0)) or ((op^.left^.optype in [cgLong,cgULong]) and (op^.left^.lval <> 0)) or (not (op^.left^.optype in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong])) then begin Combine(tree, op); skip := true; end; {if} end; {if} if not skip then begin {check for matches in the children} if op2 = nil then if tree^.left <> nil then op2 := Match(op, tree^.left); if op2 = nil then if tree^.right <> nil then op2 := Match(op, tree^.right); end; {if} Match := op2; end; {Match} begin {CheckTree} op^.parents := 0; {zero the parent counter} if op^.left <> nil then {check the children} CheckTree(op^.left, bb); if op^.right <> nil then CheckTree(op^.right, bb); if op^.next = nil then {look for a match to the current code} if not (op^.opcode in [pc_cup,pc_cui,pc_tl1,pc_bno]) then begin op2 := nil; op3 := bb^.code; while (op2 = nil) and (op3 <> nil) do begin op2 := Match(op, op3); if op2 <> nil then if op2^.next = nil then begin op := op2; bb := nil; op3 := nil; end ;{if} if op3 <> nil then op3 := op3^.next; end; {while} end; {if} end; {CheckTree} procedure CountParents (op: icptr); { increment the parent counter for all children of this node } { } { parameters: } { op - node for which to check the children } begin {CountParents} if op^.parents = 0 then begin if op^.left <> nil then begin CountParents(op^.left); op^.left^.parents := op^.left^.parents + 1; end; {if} if op^.right <> nil then begin CountParents(op^.right); op^.right^.parents := op^.right^.parents + 1; end; {if} end; {if} end; {CountParents} procedure CreateTemps (var op: icptr; bb: blockPtr; var lop: icptr); { create temps for nodes with multiple parents } { } { parameters: } { op - node for which to create temps } { bb - current basic block } { lop - predecessor to op } var children: boolean; {does this node have children?} llab: integer; {local label number; for temp} op2, str: icptr; {new opcodes} optype: baseTypeEnum; {type of the temp variable} begin {CreateTemps} children := false; {create temps for the children} if op^.left <> nil then begin children := true; CreateTemps(op^.left, bb, lop); end; {if} if op^.right <> nil then begin children := true; CreateTemps(op^.right, bb, lop); end; {if} if children then if op^.parents > 1 then begin optype := TypeOf(op); {create a temp label} llab := GetTemp(bb, TypeSize(optype)); {make a copy of the duplicated tree} op2 := pointer(Calloc(sizeof(intermediate_code))); op2^ := op^; op^.opcode := pc_lod; {substitute a load of the temp} op^.optype := optype; op^.parents := 1; op^.r := llab; op^.q := 0; op^.left := nil; op^.right := nil; {store the temp result} str := pointer(Calloc(sizeof(intermediate_code))); str^.opcode := pc_str; str^.optype := optype; str^.r := llab; str^.q := 0; str^.left := op2; if lop = nil then begin {insert the store in the basic block} str^.next := bb^.code; bb^.code := str; end {if} else begin str^.next := lop^.next; lop^.next := str; end; {else} lop := str; end; {if} end; {CreateTemps} begin {CommonSubexpressionElimination} temps := nil; {no temps allocated, yet} repeat {identify common parts} done := true; bb := DAGblocks; while bb <> nil do begin Spin; op := bb^.code; if op <> nil then begin CheckTree(bb^.code, bb); while op^.next <> nil do begin CheckTree(op^.next, bb); if op^.next <> nil then op := op^.next; end; {while} end; {if} bb := bb^.next; end; {while} until done; bb := DAGblocks; {count the number of parents} while bb <> nil do begin op := bb^.code; Spin; while op <> nil do begin CountParents(op); op := op^.next; end; {while} bb := bb^.next; end; {while} bb := DAGblocks; {check for blocked instructions} while bb <> nil do begin op := bb^.code; Spin; while op <> nil do begin CheckForBlocks(op); op := op^.next; end; {while} bb := bb^.next; end; {while} bb := DAGblocks; {create temps for common subexpressions} while bb <> nil do begin op := bb^.code; lop := nil; ResetTemps; Spin; while op <> nil do begin CreateTemps(op, bb, lop); lop := op; op := op^.next; end; {while} bb := bb^.next; end; {while} DisposeTemps; {get rid of the temp variable list} end; {CommonSubexpressionElimination} {- Loop Optimizations ------------------------------------------} procedure AddOperation (op: icptr; var lp: iclist); { Add an operation to an operation list } { } { parameters: } { op - operation to add } { lp - list to add the operation to } var inList: boolean; {is op already in the list?} llp: iclist; {work pointer} begin {AddOperation} llp := lp; inList := false; while llp <> nil do if MatchLoc(llp^.op, op) then begin inList := true; llp := nil; end {if} else llp := llp^.next; if not inList then begin new(llp); llp^.next := lp; lp := llp; llp^.op := op; end; {if} end; {AddOperation} procedure DisposeBlkList (var blk: blockListPtr); { dispose of all entries in the block list } { } { parameters: } { blk - list of blocks to dispose of } var bk1, bk2: blockListPtr; {work pointers} begin {DisposeBlkList} bk1 := blk; blk := nil; while bk1 <> nil do begin bk2 := bk1; bk1 := bk2^.next; dispose(bk2); end; {while} end; {DisposeBlkList} procedure DisposeOpList (var oplist: iclist); { dispose of all entries in the list } { } { parameters: } { oplist - operation list to dispose of } var op1, op2: iclist; {work pointers} begin {DisposeOpList} op1 := oplist; oplist := nil; while op1 <> nil do begin op2 := op1; op1 := op2^.next; dispose(op2); end; {while} end; {DisposeOpList} procedure DumpLoopLists; { dispose of lists created by ReachingDefinitions and Dominators} var bb: blockPtr; {used to trace basic block list} dom: blockListPtr; {used to dispose of a dominator} begin {DumpLoopLists} bb := DAGBlocks; while bb <> nil do begin DisposeOpList(bb^.c_in); {dump the reaching definition lists} DisposeOpList(bb^.c_out); DisposeOpList(bb^.c_gen); DisposeBlkList(bb^.dom); while bb^.dom <> nil do begin {dump the dominator lists} dom := bb^.dom; bb^.dom := dom^.next; dispose(dom); end; {while} bb := bb^.next; end; {while} end; {DumpLoopLists} procedure AddLoads (jp: icptr; var lp: iclist); { Add any load addresses from the children of this } { operation } { } { parameters: } { jp - operation to check } { lp - list to add the loads to } begin {AddLoads} if jp^.opcode in [pc_lda,pc_lao,pc_lod,pc_lod] then AddOperation(jp, lp) else begin if jp^.left <> nil then AddLoads(jp^.left, lp); if jp^.right <> nil then AddLoads(jp^.right, lp); end {else} end; {AddLoads} procedure FlagIndirectUses; { Find all variables that could be changed by an indirect } { access. } var bb: blockPtr; {used to trace block list} procedure Check (op: icptr; doingInd: boolean); { Check op and its children & followers for dangerous } { references } { } { parameters: } { op - operation to check } { doingInd - are we doing a pc_ind? If so, pc_lda's } { are safe } var lDoingInd: boolean; {local doingInd} begin {Check} while op <> nil do begin if op^.opcode = pc_ind then lDoingInd := true else lDoingInd := doingInd; if op^.left <> nil then Check(op^.left, lDoingInd); if op^.right <> nil then Check(op^.right, lDoingInd); if op^.opcode in [pc_lao,pc_cpo,pc_ldo,pc_sro,pc_gil,pc_gli, pc_gdl,pc_gld] then AddOperation(op, c_ind) else if op^.opcode = pc_ind then begin if op^.left^.opcode = pc_ind then AddLoads(op^.left^.left, c_ind); end {else if} else if op^.opcode = pc_lda then if not doingInd then AddOperation(op, c_ind); op := op^.next; end; {while} end; {Check} begin {FlagIndirectUses} c_ind := nil; bb := DAGBlocks; while bb <> nil do begin Check(bb^.code, false); bb := bb^.next; end; {while} end; {FlagIndirectUses} procedure DoLoopOptimization; { Perform optimizations related to loops and data flow } type dftptr = ^dftrecord; {depth first tree edges} dftrecord = record next: dftptr; from, dest: blockPtr; end; var backEdge: dftptr; {list of back edges} dft: dftptr; {depth first tree} dft2: dftptr; {work pointer} function DFN (i: integer): blockPtr; { find the basic block with dfn index of i } { } { parameters: } { i - index to look for } { } { Returns: block pointer, or nil if there is none } var bb: blockPtr; {used to trace block list} begin {DFN} bb := DAGBlocks; DFN := nil; while bb <> nil do begin if bb^.dfn = i then begin DFN := bb; bb := nil; end else bb := bb^.next; end; {while} end; {DFN} function MemberDFNList (dfn: integer; bl: blockListPtr): boolean; { See if dfn is a member of the list bl } { } { parameters: } { dfn - block number to check } { bl - list of block numbers to check } { } { Returns: True if dfn is in bl, else false. } begin {MemberDFNList} MemberDFNList := false; while bl <> nil do if bl^.dfn = dfn then begin MemberDFNList := true; bl := nil; end {if} else bl := bl^.next; end; {MemberDFNList} function FindDAG (q: integer): blockPtr; { Find the DAG containing label q } { } { parameters: } { q - label to find } { } { Returns: pointer to the proper basic block } var bb: blockPtr; {used to trace basic block list} begin {FindDAG} bb := DAGBlocks; FindDAG := nil; while bb <> nil do begin if bb^.code^.opcode = dc_lab then if bb^.code^.q = q then begin FindDAG := bb; bb := nil; end; {if} if bb <> nil then bb := bb^.next; end; {while} end; {FindDAG} procedure DepthFirstOrder; { Number the DAG for depth first order } var bb: blockPtr; {used to trace basic block lists} i: integer; {dfn index} procedure Search (bb: blockPtr); { Search this block } { } { parameters: } { bb - basic block to search } var blk: blockPtr; {work block} ndft: dftptr; {for new tree entries} op: icptr; {used to trace operation list} function NotUnconditional: boolean; { See if the block ends with something other than an } { unconditional jump } { } { Returns: True if the block ends with something other } { than pc_ujp or pc_add, else false } var op: icptr; {used to trace the list} begin {NotUnconditional} NotUnconditional := true; op := bb^.code; if op <> nil then begin while op^.next <> nil do op := op^.next; if op^.opcode in [pc_add,pc_ujp] then NotUnconditional := false; end; {if} end; {NotUnconditional} begin {Search} Spin; if bb <> nil then if not bb^.visited then begin bb^.visited := true; if NotUnconditional then if bb^.next <> nil then begin new(ndft); ndft^.next := dft; dft := ndft; ndft^.from := bb; ndft^.dest := bb^.next; Search(bb^.next); end; {if} op := bb^.code; while op <> nil do begin if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin blk := FindDAG(op^.q); new(ndft); if blk^.visited then begin ndft^.next := backEdge; backEdge := ndft; end {if} else begin ndft^.next := dft; dft := ndft; Search(blk); end; {else} ndft^.from := bb; ndft^.dest := blk; end; {if} op := op^.next; end; {while} bb^.dfn := i; i := i-1; end; {if} end; {Search} begin {DepthFirstOrder} dft := nil; backEdge := nil; i := 0; bb := DAGblocks; while bb <> nil do begin bb^.visited := false; i := i+1; bb := bb^.next; end; {while} Search(DAGBlocks); end; {DepthFirstOrder} procedure Dominators; { Find a list of dominators for each node } var bb: blockPtr; {used to trace the block list} change: boolean; {for loop termination test} i, j: integer; {loop variables} maxdfn, mindfn: integer; {max and min dfn values used} procedure Add (var dom: blockListPtr; dfn: integer); { Add dfn to the list of dominators } { } { parameters: } { dom - dominator list } { dfn - new dominator number } var dp: blockListPtr; {new node} begin {Add} new(dp); dp^.last := nil; dp^.next := dom; dom^.last := dp; dom := dp; dp^.dfn := dfn; end; {Add} procedure CheckPredecessors (bb: blockPtr; bl: dftptr); { Eliminate nodes that don't dominate a predecessor } { } { parameters: } { bb - block being checked } { bl - list of edges to check for predecessors } var dp: blockListPtr; {list of dominator numbers} tdp: blockListPtr; {used to remove a dominator entry} begin {CheckPredecessors} while bl <> nil do begin if bl^.dest = bb then begin dp := bb^.dom; while dp <> nil do if dp^.dfn <> bb^.dfn then if not MemberDFNList(dp^.dfn, bl^.from^.dom) then begin change := true; tdp := dp; if tdp^.last = nil then bb^.dom := tdp^.next else tdp^.last^.next := tdp^.next; if tdp^.next <> nil then tdp^.next^.last := tdp^.last; dp := tdp^.next; dispose(tdp); end {if} else dp := dp^.next else dp := dp^.next; end; {if} bl := bl^.next; end; {while} end; {CheckPredecessors} begin {Dominators} Spin; maxdfn := 0; {find the largest dfn} bb := DAGBlocks; while bb <> nil do begin if bb^.dfn > maxdfn then maxdfn := bb^.dfn; bb := bb^.next; end; {while} Add(DAGBlocks^.dom, DAGBlocks^.dfn); {the first node is it's own dominator} mindfn := DAGBlocks^.dfn; {assume all other nodes are dominated by every other node} for i := mindfn+1 to maxdfn do begin bb := DFN(i); if bb <> nil then for j := mindfn to maxdfn do Add(bb^.dom, j); end; {for} repeat {iterate to the true set of dominators} change := false; for i := mindfn+1 to maxdfn do begin bb := DFN(i); CheckPredecessors(bb, dft); CheckPredecessors(bb, backEdge); end; {for} until not change; end; {Dominators} procedure ReachingDefinitions; { find the list of reaching definitions for each basic block } var bb: blockPtr; {block being scanned} change: boolean; {loop termination test} i: integer; {node index number} newIn: iclist; {list of inputs} function Gen (op: icptr): iclist; { find a list of generated values } { } { parameters: } { op - list of intermediate codes to scan } { } { Returns: list of generated definitions } var gp: iclist; {list of generated definitions} indFound: boolean; {has an indirect store been found?} procedure Check (ip: icptr); { Add any result from ip to gp } { } { parameters: } { ip - instruction to check } var lc_ind: iclist; {used to trace the c_ind list} begin {Check} if ip^.left <> nil then Check(ip^.left); if ip^.right <> nil then Check(ip^.right); if ip^.opcode in [pc_str,pc_sro,pc_cop,pc_cpo,pc_lli,pc_lil,pc_lld,pc_ldl, pc_gli,pc_gil,pc_gld,pc_gdl] then AddOperation(ip, gp) else if ip^.opcode in [pc_mov,pc_sto,pc_cpi,pc_iil,pc_ili,pc_idl,pc_ild] then AddLoads(ip, gp); if not indFound then if ip^.opcode in [pc_sto,pc_cpi,pc_iil,pc_ili,pc_idl,pc_ild,pc_cup,pc_cui,pc_tl1] then begin lc_ind := c_ind; while lc_ind <> nil do begin AddOperation(lc_ind^.op, gp); lc_ind := lc_ind^.next; end; {while} indFound := true; end; {if} end; {Check} begin {Gen} indFound := false; gp := nil; while op <> nil do begin Check(op); op := op^.next; end; {while} Gen := gp; end; {Gen} function EqualSets (l1, l2: iclist): boolean; { See if two sets of stores and copies are equivalent } { } { parameters: } { l1, l2 - lists of copies and stores } { } { Returns: True if the lists are equivalent, else false } { } { Notes: The members of each list are assumed to be } { unique within that list. } var c1, c2: integer; {number of elements in the sets} l3: iclist; {used to trace the lists} matchFound: boolean; {was a match found?} begin {EqualSets} EqualSets := false; {assume they are not equal} c1 := 0; {count the elements of l1} l3 := l1; while l3 <> nil do begin c1 := c1+1; l3 := l3^.next; end; {while} c2 := 0; {count the elements of l2} l3 := l2; while l3 <> nil do begin c2 := c2+1; l3 := l3^.next; end; {while} if c1 = c2 then begin {make sure each member of l1 is in l2} EqualSets := true; while l1 <> nil do begin matchFound := false; l3 := l2; while l3 <> nil do begin if MatchLoc(l1^.op, l3^.op) then begin l3 := nil; matchFound := true; end {if} else l3 := l3^.next; end; {while} if not matchFound then begin EqualSets := false; l1 := nil; end {if} else l1 := l1^.next; end; {while} end; {if} end; {EqualSets} function Union (l1, l2: iclist): iclist; { Returns a list that is the union of two input lists } { } { parameters: } { l1, l2 - lists } { } { Returns: New, dynamically allocated list that includes } { all of the members in l1 and l2. } { } { Notes: } { 1. If there are duplicates, the member from l1 is } { returned. } { 2. It is assumed that all members of l1 and l2 are } { unique within their own list. } { 3. The original lists are not disturbed. } { 4. The caller is responsible for disposing of the } { memory used by the list. } var lp: iclist; {new list pointer} np: iclist; {new list member pointer} tp: iclist; {temp list pointer} begin {Union} lp := nil; tp := l1; while tp <> nil do begin new(np); np^.next := lp; lp := np; np^.op := tp^.op; tp := tp^.next; end; {while} while l2 <> nil do begin if not Member(l2^.op, l1) then begin new(np); np^.next := lp; lp := np; np^.op := l2^.op; end; {if} l2 := l2^.next; end; {while} Union := lp; end; {Union} function UnionOfPredecessors (bptr: blockPtr): iclist; { create a union of the outputs of predecessors to bptr } { } { parameters: } { bptr - block for which to look for predecessors } { } { Returns: Resulting set } var bp: dftptr; {used to trace edge lists} plist: iclist; {result list} tlist: iclist; {temp result list} begin {UnionOfPredecessors} plist := nil; bp := dft; while bp <> nil do begin if bp^.dest = bptr then begin tlist := Union(plist, bp^.from^.c_out); DisposeOpList(plist); plist := tlist; end; {if} bp := bp^.next; end; {while} bp := backEdge; while bp <> nil do begin if bp^.dest = bptr then begin tlist := Union(plist, bp^.from^.c_out); DisposeOpList(plist); plist := tlist; end; {if} bp := bp^.next; end; {while} UnionOfPredecessors := plist; end; {UnionOfPredecessors} begin {ReachingDefinitions} i := 1; {initialize the lists} repeat bb := DFN(i); if bb <> nil then begin bb^.c_in := nil; bb^.c_gen := Gen(bb^.code); bb^.c_out := Union(nil, bb^.c_gen); end; {if} i := i+1; until bb = nil; repeat {iterate to a solution} change := false; i := 1; repeat Spin; bb := DFN(i); if bb <> nil then begin newIn := UnionOfPredecessors(bb); if not EqualSets(bb^.c_in, newIn) then begin {IN[n] := newIn} DisposeOpList(bb^.c_in); bb^.c_in := newIn; newIn := nil; {OUT[n] := IN[n] - KILL[n] U GEN[n]} DisposeOpList(bb^.c_out); bb^.c_out := Union(bb^.c_in, nil); change := true; end; {if} DisposeOpList(newIn); end; {if} i := i+1; until bb = nil; until not change; end; {ReachingDefinitions} procedure LoopInvariantRemoval; { Remove all loop invariant computations } type loopPtr = ^loopRecord; {blocks in a list} loopRecord = record next: loopPtr; {next entry} block: blockPtr; {code block} exit: boolean; {is this a loop exit?} end; loopListPtr = ^loopListRecord; {list of loop lists} loopListRecord = record next: loopListPtr; loop: loopPtr; end; var icount: integer; {order invariant found} loops: loopListPtr; {list of loops} lp: loopPtr; {used to trace loop lists} llp: loopListPtr; {used to trace the list of loops} procedure FindLoops; { Create a list of the natural loops } var blk: blockPtr; {target block for a jump} bp: dftptr; {used to trace the back edges} lp, lp2: loopPtr; {used to reverse the list} llp: loopListPtr; {loop list header entry} llp2: loopListPtr; {used to reverse the list} op: icptr; {used to trace the opcode list} procedure Add (block: blockPtr); { Add a block to the current loop list } { } { parameters: } { block - block to add } var lp: loopPtr; {new loop entry} begin {Add} new(lp); lp^.next := llp^.loop; llp^.loop := lp; lp^.block := block; lp^.exit := false; end; {Add} function InLoop (blk: blockPtr; lp: loopPtr): boolean; { See if the block is in the loop } { } { parameters: } { blk - block to check for } { lp - loop list } { } { Returns: True if blk is in the list, else false } begin {InLoop} InLoop := false; while lp <> nil do begin if lp^.block = blk then begin lp := nil; InLoop := true; end {if} else lp := lp^.next; end; {while} end; {InLoop} procedure Insert (block: blockPtr); { Insert a block into the loop list } { } { parameters: } { block - block to add } procedure AddPredecessors (block: blockPtr; bl: dftptr); { add any predecessors to the loop } { } { parameters: } { block - block for which to check for } { predecessors } { bl - list of edges to check } begin {AddPredecessors} while bl <> nil do begin if bl^.dest = block then Insert(bl^.from); bl := bl^.next; end; {while} end; {AddPredecessors} function InLoop (block: blockPtr; lp: loopPtr): boolean; { See if a block is in the loop } { } { parameters: } { block - block to check } { lp - list of blocks in the loop } { } { Returns: True if the block is in the loop, else false } begin {InLoop} InLoop := false; while lp <> nil do if lp^.block = block then begin InLoop := true; lp := nil; end {if} else lp := lp^.next; end; {InLoop} begin {Insert} if not InLoop(block, llp^.loop) then begin Add(block); AddPredecessors(block, dft); AddPredecessors(block, backEdge); end; {if} end; {Insert} begin {FindLoops} loops := nil; bp := backEdge; {scan the back edges} while bp <> nil do begin if MemberDFNList(bp^.dest^.dfn, bp^.from^.dom) then begin new(llp); {create a new loop list entry} llp^.next := loops; loops := llp; llp^.loop := nil; Add(bp^.dest); Insert(bp^.from); lp := llp^.loop; {reverse the list} llp^.loop := nil; while lp <> nil do begin lp2 := lp; lp := lp2^.next; lp2^.next := llp^.loop; llp^.loop := lp2; end; {while} lp := llp^.loop; {mark the exits} while lp <> nil do begin op := lp^.block^.code; while op <> nil do begin if op^.opcode in [pc_ujp, pc_fjp, pc_tjp, pc_add] then begin blk := FindDAG(op^.q); if not InLoop(blk, llp^.loop) then lp^.exit := true; if op^.opcode in [pc_fjp,pc_tjp] then if not InLoop(lp^.block^.next, llp^.loop) then lp^.exit := true; end; {if} op := op^.next; end; {while} lp := lp^.next; end; {while} end; {if} bp := bp^.next; end; {while} llp := loops; {reverse the loop list} loops := nil; while llp <> nil do begin llp2 := llp; llp := llp2^.next; llp2^.next := loops; loops := llp2; end; {while} end; {FindLoops} function MarkInvariants (lp: loopPtr): boolean; { Make a pass over the opcodes, marking those that are } { invariant. } { } { parameters: } { lp - loop to scan } { } { Returns: True if any new nodes were marked, else false. } var count: integer; {number of generating blocks} indirectStores: boolean; {does the loop contain indirect stores or function calls?} inhibit: boolean; {inhibit stores?} lp2: loopPtr; {used to trace the loop} op: icptr; {used to trace the instruction list} opcode: pcodes; {op^.opcode; for efficiency} procedure Check (op: icptr; olp: loopPtr); { See if this node or its children is invariant } { } { parameters: } { op - node to check } { olp - loop entry for the block containing the store } var invariant: boolean; {are the operands invariant?} function IndirectInhibit (op: icptr): boolean; { See if a store should be inhibited due to indirect } { accesses } { } { parameters: } { op - instruction to check } { } { Returns: True if the instruction should be inhibited, } { else false. } begin {IndirectInhibit} IndirectInhibit := false; if indirectStores then if Member(op, c_ind) then IndirectInhibit := true; end; {IndirectInhibit} function NoOtherStoresOrUses (lp, olp: loopPtr; op: icptr): boolean; { Check for invalid stores } { } { parameters: } { lp - loop to check } { olp - loop entry for the block containing the store } { op - store to check } { } { Returns: True if the store is valid, false if not. } { } { Notes: Specifically, these two rules are inforced: } { 1. No other stores to the same location appear in the } { loop. } { 2. All uses of the value in the loop can be reached } { only by the assign. } var lp2: loopPtr; {used to trace the loop list} op2: icptr; {used to trace code list} function SafeLoad (sop, lop: icptr; sbk, lbk: blockPtr): boolean; { See if a load is in a safe position } { } { parameters: } { sop - save opcode that may need to be left in loop } { lop - load operation that may inhibit the save } { sbk - block containing the save } { lbk - block containing the load } function First (op1, op2, stream: icptr): icptr; { See which operation comes first } { } { parmeters: } { op1, op2 - instructions to check } { stream - start of block containing the instructions } { } { Returns: First operation found, or nil if missing } var op: icptr; {temp opcode} begin {First} if stream = op1 then First := op1 else if stream = op2 then First := op2 else begin op := nil; if stream^.left <> nil then op := First(op1, op2, stream^.left); if op = nil then if stream^.right <> nil then op := First(op1, op2, stream^.right); if op = nil then if stream^.next <> nil then op := First(op1, op2, stream^.next); First := op; end; {else} end; {First} begin {SafeLoad} if sbk = lbk then SafeLoad := First(sop, lop, sbk^.code) = sop else SafeLoad := MemberDFNList(sbk^.dfn, lbk^.dom); end; {SafeLoad} function MatchStores (op, tree: icptr; opbk, treebk: blockPtr): boolean; { Check the tree for stores to the same location as op } { } { parameters: } { op - store to check for } { tree - operation tree to check } { opbk - block containing op } { treebk - block containing tree } { } { Returns: True if there are matching stores, else false } var result: boolean; {function result} begin {MatchStores} result := false; if tree^.opcode in [pc_lli,pc_lil,pc_lld,pc_ldl,pc_str,pc_cop, pc_sro,pc_cpo,pc_gli,pc_gil,pc_gld,pc_gdl] then begin if tree <> op then result := MatchLoc(op, tree); end {if} else if tree^.opcode in [pc_ldo,pc_lod] then if MatchLoc(op, tree) then result := not SafeLoad(op, tree, opbk, treebk); if not result then if tree^.left <> nil then result := MatchStores(op, tree^.left, opbk, treebk); if not result then if tree^.right <> nil then result := MatchStores(op, tree^.right, opbk, treebk); MatchStores := result; end; {MatchStores} begin {NoOtherStoresOrUses} NoOtherStoresOrUses := true; lp2 := lp; while lp2 <> nil do begin op2 := lp2^.block^.code; while op2 <> nil do if MatchStores(op, op2, olp^.block, lp2^.block) then begin op2 := nil; lp2 := nil; NoOtherStoresOrUses := false; end {if} else op2 := op2^.next; if lp2 <> nil then lp2 := lp2^.next; end; {while} end; {NoOtherStoresOrUses} function NumberOfGens (op: icptr; lp: loopPtr): integer; { Count the number of nodes that generate op } { } { parameters: } { op - instruction to check } { lp - loop to check } var count: integer; {number of generators} begin {NumberOfGens} count := 0; while lp <> nil do begin if Member(op, lp^.block^.c_gen) then count := count+1; lp := lp^.next; end; {while} NumberOfGens := count; end; {NumberOfGens} function PreviousStore (op, list: icptr): boolean; { See if the last save was invariant } { } { parameters: } { op - load operation } { list - block containing the load } { } { Returns: True if the previous store was invariant, else } { false. } var indop: icptr; {any indirect operation after strop} strop: icptr; {last matching store before op} procedure Check (lop: icptr); { Stop if this is lop; save if it is a matching store } { } { parameters: } { lop - check this operation and it's children } begin {Check} if lop^.left <> nil then Check(lop^.left); if list <> nil then if lop^.right <> nil then Check(lop^.right); if list <> nil then if lop = op then list := nil else if (lop^.opcode in [pc_str,pc_cop,pc_str,pc_cop]) and MatchLoc(op, lop) then begin strop := lop; indop := nil; end {else if} else if op^.opcode in [pc_sto,pc_cpi,pc_iil,pc_ili,pc_idl,pc_ild,pc_cup,pc_cui,pc_tl1] then indop := op; end; {Check} function Inhibit (indop, op: icptr): boolean; { See if op should be inhibited due to indirect stores } { } { parameters: } { indop - inhibiting indirect store or nil } { op - instruction to check } begin {Inhibit} Inhibit := false; if indop <> nil then if Member(op, c_ind) then Inhibit := true; end; {Inhibit} begin {PreviousStore} indop := nil; strop := nil; while list <> nil do begin Check(list); if list <> nil then list := list^.next; end; {while} PreviousStore := false; if strop <> nil then if strop^.parents <> 0 then if not Inhibit(indop, op) then PreviousStore := true; end; {PreviousStore} begin {Check} if op^.parents = 0 then begin invariant := true; if op^.left <> nil then begin Check(op^.left, olp); if op^.left^.parents = 0 then invariant := false; end; {if} if op^.right <> nil then begin Check(op^.right, olp); if op^.right^.parents = 0 then invariant := false; end; {if} if invariant then begin opcode := op^.opcode; if opcode in [pc_adi,pc_adl,pc_adr,pc_and,pc_lnd,pc_bnd,pc_bal, pc_bnt,pc_bnl,pc_bor,pc_blr,pc_bxr,pc_blx,pc_bno, pc_dec,pc_dvi,pc_udi,pc_dvl,pc_udl,pc_dvr,pc_equ,pc_neq, pc_grt,pc_les,pc_geq,pc_leq,pc_inc,pc_ind,pc_ior,pc_lor, pc_ixa,pc_lad,pc_lao,pc_lca,pc_lda,pc_ldc,pc_mod,pc_uim, pc_mdl,pc_ulm,pc_mpi,pc_umi,pc_mpl,pc_uml,pc_mpr,pc_ngi, pc_ngl,pc_ngr,pc_not,pc_pop,pc_sbf,pc_sbi,pc_sbl,pc_sbr, pc_shl,pc_sll,pc_shr,pc_usr,pc_slr,pc_vsr,pc_tri] then begin op^.parents := icount; icount := icount+1; end {if} else if opcode = pc_cnv then begin if op^.q & $000F <> ord(cgVoid) then begin op^.parents := icount; icount := icount+1; end; {if} end {else if} else if opcode in [pc_sro,pc_sto,pc_str,pc_cop,pc_cpo,pc_cpi,pc_cbf] then begin if not inhibit then if not IndirectInhibit(op) then if NoOtherStoresOrUses(lp, olp, op) then begin op^.parents := icount; icount := icount+1; end; {if} end {else if} else if opcode in [pc_ldo,pc_lod] then begin {invariant if there is an immediately preceeding invariant store} if PreviousStore(op, lp2^.block^.code) then begin op^.parents := icount; icount := icount+1; end {if} else if not Member(op, lp2^.block^.c_gen) then begin {invariant if there are no generators in the loop} count := NumberOfGens(op, lp); if count = 0 then begin op^.parents := icount; icount := icount+1; end {if} else if count = 1 then begin {invariant if there is one generator AND the generator} {is not in the current block AND no reaching } {definitions for the loop AND generating statement is } {invariant } if memberOp^.parents <> 0 then if not Member(op, lp^.block^.c_in) then begin op^.parents := icount; icount := icount+1; end; {if} end; {else if} end; {else} end {else if} end; {if} if op^.parents <> 0 then MarkInvariants := true; end; {if} end; {Check} function CheckForIndirectStores (lp: loopPtr): boolean; { See if there are any indirect stores or function calls in } { the loop } { } { parameters: } { lp - loop to check } { } { Returns: True if there are indirect stores or function } { calls, else false. } function CheckOps (op: icptr): boolean; { Check this operation list } { } { parameters: } { op - operation list to check } { } { Returns: True if an indirect store or function call is } { found, else false. } var result: boolean; {value to return} begin {CheckOps} result := false; while op <> nil do begin if op^.opcode in [pc_sto,pc_cpi,pc_iil,pc_ili,pc_idl,pc_ild,pc_cup,pc_cui, pc_tl1,pc_mov] then begin result := true; op := nil; end {if} else begin if op^.left <> nil then result := CheckOps(op^.left); if not result then if op^.right <> nil then result := CheckOps(op^.right); if result then op := nil; end; {if} if op <> nil then op := op^.next; end; {while} CheckOps := result; end; {CheckOps} begin {CheckForIndirectStores} CheckForIndirectStores := false; while lp <> nil do if CheckOps(lp^.block^.code) then begin CheckForIndirectStores := true; lp := nil; end {if} else lp := lp^.next; end; {CheckForIndirectStores} function DominatesExits (dfn: integer; lp: loopPtr): boolean; { See if this block dominates all loop exits } { } { parameters: } { dfn - block that must dominate exits } { lp - loop list } { } { Returns: True if the block dominates all exits, else false. } var dom: blockListPtr; {used to trace dominator list} begin {DominatesExits} DominatesExits := true; while lp <> nil do begin if lp^.exit then begin dom := lp^.block^.dom; while dom <> nil do if dom^.dfn = dfn then dom := nil else begin dom := dom^.next; if dom = nil then begin lp := nil; DominatesExits := false; end; {if} end; {else} end; {if} if lp <> nil then lp := lp^.next; end; {while} end; {DominatesExits} begin {MarkInvariants} MarkInvariants := false; lp2 := lp; while lp2 <> nil do begin inhibit := not DominatesExits(lp2^.block^.dfn, lp); indirectStores := CheckForIndirectStores(lp); op := lp2^.block^.code; while op <> nil do begin Check(op, lp2); op := op^.next; end; {while} lp2 := lp2^.next; end; {while} end; {MarkInvariants} procedure RemoveInvariants (llp: loopListPtr); { Remove loop invariant calculations } { } { parameters: } { llp - pointer to the loop entry to process } var icount, oldIcount: integer; {invariant order counters} nhp: blockPtr; {new loop hedaer pointer} op1, op2, op3: icptr; {used to reverse the code list} procedure CreateHeader; { Create the new loop header } { } { Notes: As a side effect, CreateHeader sets nhp to point to } { the new loop header. } var lp: loopPtr; {new loop list entry} ohp: blockPtr; {old loop hedaer pointer} begin {CreateHeader} nhp := pointer(Calloc(sizeof(block))); {create the new block} ohp := llp^.loop^.block; {insert it in the block list} nhp^.last := ohp^.last; if nhp^.last <> nil then nhp^.last^.next := nhp; nhp^.next := ohp; ohp^.last := nhp; new(lp); {add it to the loop list} lp^.next := llp^.loop; llp^.loop := lp; lp^.block := nhp; lp^.exit := false; end; {CreateHeader} function FindInvariant (ic: integer): integer; { Find the next invariant calculation } { } { parameters: } { ic - base count; the new count must exceed this } { } { Returns: count for the invariant record to remove } var lp: loopPtr; {used to trace loop list} op: icptr; {used to trace code list} nic: integer; {lowest count > ic} procedure Check (op: icptr); { See if op or its children represent a newer invariant } { calculation than the one numbered nic } { } { parameters: } { op - instruction to check } { } { Notes: Rejecting pc_bno here is rather odd, but it allows } { expressions _containing_ pc_bno to be removed without } { messing up pc_tri operations by allowing pc_bno to be } { removed as the top level of an expression. } begin {Check} if op^.parents = 0 then begin if op^.left <> nil then Check(op^.left); if op^.right <> nil then Check(op^.right); end {if} else begin if op^.parents < nic then if op^.parents > ic then if op^.opcode <> pc_bno then nic := op^.parents; end; {else} end; {Check} begin {FindInvariant} nic := maxint; lp := llp^.loop; while (lp <> nil) and (nic <> ic+1) do begin op := lp^.block^.code; while op <> nil do begin Check(op); op := op^.next; end; {while} lp := lp^.next; end; {while} FindInvariant := nic; end; {FindInvariant} procedure RemoveInvariant (ic: integer); { Move the invariant calculation to the header } { } { parameters: } { ic - index number for instruction to remove } var done: boolean; {loop termination test} lp: loopPtr; {used to trace loop list} op: icptr; {used to trace code list} procedure Check (op: icptr); { See if a child of op is the target instruction to move } { (If so, move it.) } { } { parameters: } { op - instruction to check } procedure Remove (var op: icptr); { Move a calculation to the loop header } { } { parameters: } { op - invariant calculation to move } var loc, op2, str: icptr; {new opcodes} optype: baseTypeEnum; {type of the temp variable} begin {Remove} if (op^.left <> nil) or (op^.right <> nil) then begin optype := TypeOf(op); {create a temp label} loc := pointer(Calloc(sizeof(intermediate_code))); loc^.opcode := dc_loc; loc^.optype := cgWord; maxLoc := maxLoc + 1; loc^.r := maxLoc; loc^.q := TypeSize(optype); loc^.next := nhp^.code; nhp^.code := loc; {make a copy of the tree} op2 := pointer(Malloc(sizeof(intermediate_code))); op2^ := op^; op^.opcode := pc_lod; {substitute a load of the temp} op^.optype := optype; op^.r := loc^.r; op^.q := 0; op^.left := nil; op^.right := nil; {store the temp result} str := pointer(Calloc(sizeof(intermediate_code))); str^.opcode := pc_str; str^.optype := optype; str^.r := loc^.r; str^.q := 0; str^.left := op2; str^.next := loc^.next; {insert the store in the basic block} loc^.next := str; end; {if} done := true; end; {Remove} begin {Check} if op^.left <> nil then begin if op^.left^.parents = ic then Remove(op^.left); if not done then Check(op^.left); end; {if} if not done then if op^.right <> nil then begin if op^.right^.parents = ic then Remove(op^.right); if not done then Check(op^.right); end; {if} end; {Check} procedure RemoveTop (var op: icptr); { Move a top-level instruction to the header } { } { parameters: } { op - top level instruction to remove } var op2: icptr; {temp operation} begin {RemoveTop} op2 := op; op := op^.next; op2^.next := nhp^.code; nhp^.code := op2; end; {RemoveTop} begin {RemoveInvariant} lp := llp^.loop; done := false; while not done do begin op := lp^.block^.code; if op <> nil then if op^.parents = ic then begin RemoveTop(lp^.block^.code); done := true; end {if} else begin Check(op); while (op^.next <> nil) and (not done) do begin if op^.next^.parents = ic then begin RemoveTop(op^.next); done := true; end {if} else Check(op^.next); if op^.next <> nil then op := op^.next; end; {while} end; {else} lp := lp^.next; if lp = nil then done := true; end; {while} end; {RemoveInvariant} begin {RemoveInvariants} CreateHeader; {create a loop header block} icount := 0; {find & remove all invariants} repeat oldIcount := icount; icount := FindInvariant (icount); if icount <> maxint then RemoveInvariant(icount); until icount = maxint; op1 := nhp^.code; {reverse the new code list} op2 := nil; while op1 <> nil do begin op3 := op1; op1 := op1^.next; op3^.next := op2; op2 := op3; end; {while} nhp^.code := op2; end; {RemoveInvariants} procedure ZeroParents (lp: loopPtr); { Zero the parents field in all nodes } { } { parameters: } { lp - loop for which to zero the parents } var op: icptr; {used to trace the opcode list} procedure Zero (op: icptr); { Zero the parents field for this node and its } { children. } { } { parameters: } { op - node to zero } begin {Zero} op^.parents := 0; if op^.left <> nil then Zero(op^.left); if op^.right <> nil then Zero(op^.right); end; {Zero} begin {ZeroParents} while lp <> nil do begin op := lp^.block^.code; while op <> nil do begin Zero(op); op := op^.next; end; {while} lp := lp^.next; end; {while} end; {ZeroParents} begin {LoopInvariantRemoval} Spin; FindLoops; {find a list of natural loops} llp := loops; {scan the loops...} icount := 1; while llp <> nil do begin Spin; ZeroParents(llp^.loop); {set the parents field to zero} while MarkInvariants(llp^.loop) do {mark the loop invariant computations} ; if icount <> 1 then RemoveInvariants(llp); {remove loop invariant calculations} llp := llp^.next; end; {while} while loops <> nil do begin {dispose of the loop lists} while loops^.loop <> nil do begin lp := loops^.loop; loops^.loop := lp^.next; dispose(lp); end; {while} llp := loops; loops := llp^.next; dispose(llp); end; {while} end; {LoopInvariantRemoval} begin {DoLoopOptimization} DepthFirstOrder; {create the depth first tree} ReachingDefinitions; {find reaching definitions} Dominators; {find the lists of dominators} LoopInvariantRemoval; {remove loop invariant computations} while dft <> nil do begin {dispose of the depth first tree} dft2 := dft; dft := dft2^.next; dispose(dft2); end; {while} while backEdge <> nil do begin {dispose of the back edge list} dft2 := backEdge; backEdge := dft2^.next; dispose(dft2); end; {while} end; {DoLoopOptimization} {---------------------------------------------------------------} procedure DAG {code: icptr}; { place an op code in a DAG or tree } { } { parameters: } { code - opcode } var temp: icptr; {temp node} procedure Generate; { generate the code for the current procedure } var op: icptr; {temp opcode pointers} procedure BasicBlocks; { Break the code up into basic blocks } var blast: blockPtr; {last block pointer} bp: blockPtr; {current block pointer} cb: icptr; {last code in block pointer} cp: icptr; {current code pointer} begin {BasicBlocks} cp := DAGhead; DAGblocks := nil; if cp <> nil then begin bp := pointer(Calloc(sizeof(block))); DAGblocks := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; while cp <> nil do {labels start a new block} if cp^.opcode = dc_lab then begin Spin; bp := pointer(Calloc(sizeof(block))); bp^.last := blast; blast^.next := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; end {if} {conditionals are followed by a new block} else if cp^.opcode in [pc_fjp, pc_tjp, pc_ujp, pc_ret, pc_xjp] then begin Spin; while cp^.next^.opcode = pc_add do begin cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; end; {while} cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; bp := pointer(Calloc(sizeof(block))); bp^.last := blast; blast^.next := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; end {else if} else begin {all other statements get added to a block} cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; end; {else} end; {if} end; {BasicBlocks} begin {Generate} if peepHole then {peephole optimization} repeat rescan := false; PeepHoleOptimization(DAGhead); op := DAGHead; while op^.next <> nil do begin Spin; PeepHoleOptimization(op^.next); op := op^.next; end; {while} CheckLabels; until not rescan; BasicBlocks; {build the basic blocks} if commonSubexpression or loopOptimizations then if not volatile then FlagIndirectUses; {create a list of all indirect uses} if commonSubexpression then {common sub-expression removal} if not volatile then CommonSubexpressionElimination; if loopOptimizations then {loop optimizations} if not volatile then DoLoopOptimization; { if printSymbols then {debug} { PrintBlocks(@'DAG: ', DAGblocks); {debug} if commonSubexpression or loopOptimizations then if not volatile then DisposeOpList(c_ind); {dispose of indirect use list} Gen(DAGblocks); {generate native code} if loopOptimizations then {dump and dynamic space} if not volatile then DumpLoopLists; DAGhead := nil; {reset the DAG pointers} end; {Generate} procedure Push (code: icptr); { place a node on the operation stack } { } { parameters: } { code - node } begin {Push} code^.next := DAGhead; DAGhead := code; end; {Push} function Pop: icptr; { pop a node from the operation stack } { } { returns: node pointer or nil } var node: icptr; {node poped} tn: icptr; {temp node} begin {Pop} node := DAGhead; if node = nil then Error(cge1) else begin DAGhead := node^.next; node^.next := nil; end; {else} if node^.opcode = dc_loc then begin tn := node; node := Pop; Push(tn); end; {if} Pop := node; end; {Pop} procedure Reverse; { Reverse the operation stack } var list, temp: icptr; {work pointers} begin {Reverse} list := nil; while DAGhead <> nil do begin temp := DAGhead; DAGhead := temp^.next; temp^.next := list; list := temp; end; {while} DAGhead := list; end; {Reverse} begin {DAG} case code^.opcode of pc_bnt, pc_bnl, pc_cnv, pc_dec, pc_inc, pc_ind, pc_lbf, pc_lbu, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_stk, pc_cop, pc_cpo, pc_tl1, pc_sro, pc_str, pc_fjp, pc_tjp, pc_xjp, pc_cup, pc_pop, pc_iil, pc_ili, pc_idl, pc_ild: begin code^.left := Pop; Push(code); end; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bno, pc_bor, pc_blr, pc_bxr, pc_blx, pc_cbf, pc_cpi, pc_dvi, pc_mov, pc_udi, pc_dvl, pc_udl, pc_dvr, pc_equ, pc_geq, pc_grt, pc_leq, pc_les, pc_neq, pc_ior, pc_lor, pc_ixa, pc_mod, pc_uim, pc_mdl, pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, pc_tri, pc_sbf, pc_sto, pc_cui: begin code^.right := Pop; code^.left := Pop; Push(code); end; pc_gil, pc_gli, pc_gdl, pc_gld, pc_lil, pc_lli, pc_ldl, pc_lld, pc_lad, pc_lao, pc_lca, pc_lda, pc_ldc, pc_ldo, pc_lod, pc_nop, dc_cns, dc_glb, dc_dst, pc_lnm, pc_nam, pc_nat, dc_lab, pc_add, pc_ujp, dc_pin, pc_ent, pc_ret, dc_sym: Push(code); pc_cnn: begin code^.opcode := pc_cnv; temp := Pop; code^.left := Pop; Push(code); Push(temp); end; dc_loc: begin Push(code); if code^.r > maxLoc then maxLoc := code^.r; end; dc_prm: begin Push(code); if code^.s > maxLoc then maxLoc := code^.s; end; dc_str: begin Push(code); maxLoc := 0; end; dc_enp: begin Push(code); Reverse; Generate; end; otherwise: Error(cge1); {invalid opcode} end; {case} end; {DAG} end. \ No newline at end of file diff --git a/DAG2.pas b/DAG2.pas new file mode 100755 index 0000000..a0096b7 --- /dev/null +++ b/DAG2.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { DAG Creation } { } { Places intermediate codes into DAGs and trees. } { } {---------------------------------------------------------------} unit DAG; interface {$segment 'cg'} {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC, Gen; {---------------------------------------------------------------} procedure DAG (code: icptr); { place an op code in a DAG or tree } { } { parameters: } { code - opcode } {---------------------------------------------------------------} implementation var maxLoc: integer; {max local label number used by compiler} {-- External unsigned math routines; imported from Expression.pas --} function udiv (x,y: longint): longint; extern; function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; {---------------------------------------------------------------} procedure DAG {code: icptr}; { place an op code in a DAG or tree } { } { parameters: } { code - opcode } var temp: icptr; {temp node} procedure Generate; { generate the code for the current procedure } var op: icptr; {temp opcode pointers} procedure BasicBlocks; { Break the code up into basic blocks } var blast: blockPtr; {last block pointer} bp: blockPtr; {current block pointer} cb: icptr; {last code in block pointer} cp: icptr; {current code pointer} begin {BasicBlocks} cp := DAGhead; DAGblocks := nil; if cp <> nil then begin bp := pointer(Calloc(sizeof(block))); DAGblocks := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; while cp <> nil do {labels start a new block} if cp^.opcode = dc_lab then begin Spin; bp := pointer(Calloc(sizeof(block))); bp^.last := blast; blast^.next := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; end {if} {conditionals are followed by a new block} else if cp^.opcode in [pc_fjp, pc_tjp, pc_ujp, pc_ret, pc_xjp] then begin Spin; while cp^.next^.opcode = pc_add do begin cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; end; {while} cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; bp := pointer(Calloc(sizeof(block))); bp^.last := blast; blast^.next := bp; blast := bp; bp^.code := cp; cb := cp; cp := cp^.next; cb^.next := nil; end {else if} else begin {all other statements get added to a block} cb^.next := cp; cb := cp; cp := cp^.next; cb^.next := nil; end; {else} end; {if} end; {BasicBlocks} begin {Generate} BasicBlocks; {build the basic blocks} Gen(DAGblocks); {generate native code} DAGhead := nil; {reset the DAG pointers} end; {Generate} procedure Push (code: icptr); { place a node on the operation stack } { } { parameters: } { code - node } begin {Push} code^.next := DAGhead; DAGhead := code; end; {Push} function Pop: icptr; { pop a node from the operation stack } { } { returns: node pointer or nil } var node: icptr; {node poped} tn: icptr; {temp node} begin {Pop} node := DAGhead; if node = nil then Error(cge1) else begin DAGhead := node^.next; node^.next := nil; end; {else} if node^.opcode = dc_loc then begin tn := node; node := Pop; Push(tn); end; {if} Pop := node; end; {Pop} procedure Reverse; { Reverse the operation stack } var list, temp: icptr; {work pointers} begin {Reverse} list := nil; while DAGhead <> nil do begin temp := DAGhead; DAGhead := temp^.next; temp^.next := list; list := temp; end; {while} DAGhead := list; end; {Reverse} begin {DAG} case code^.opcode of pc_bnt, pc_bnl, pc_cnv, pc_dec, pc_inc, pc_ind, pc_lbf, pc_lbu, pc_ngi, pc_ngl, pc_ngr, pc_not, pc_stk, pc_cop, pc_cpo, pc_tl1, pc_sro, pc_str, pc_fjp, pc_tjp, pc_xjp, pc_cup, pc_pop, pc_iil, pc_ili, pc_idl, pc_ild: begin code^.left := Pop; Push(code); end; pc_adi, pc_adl, pc_adr, pc_and, pc_lnd, pc_bnd, pc_bal, pc_bno, pc_bor, pc_blr, pc_bxr, pc_blx, pc_cbf, pc_cpi, pc_dvi, pc_mov, pc_udi, pc_dvl, pc_udl, pc_dvr, pc_equ, pc_geq, pc_grt, pc_leq, pc_les, pc_neq, pc_ior, pc_lor, pc_ixa, pc_mod, pc_uim, pc_mdl, pc_ulm, pc_mpi, pc_umi, pc_mpl, pc_uml, pc_mpr, pc_psh, pc_sbi, pc_sbl, pc_sbr, pc_shl, pc_sll, pc_shr, pc_usr, pc_slr, pc_vsr, pc_tri, pc_sbf, pc_sto, pc_cui: begin code^.right := Pop; code^.left := Pop; Push(code); end; pc_gil, pc_gli, pc_gdl, pc_gld, pc_lil, pc_lli, pc_ldl, pc_lld, pc_lad, pc_lao, pc_lca, pc_lda, pc_ldc, pc_ldo, pc_lod, pc_nop, dc_cns, dc_glb, dc_dst, pc_lnm, pc_nam, pc_nat, dc_lab, pc_add, pc_ujp, dc_pin, pc_ent, pc_ret, dc_sym: Push(code); pc_cnn: begin code^.opcode := pc_cnv; temp := Pop; code^.left := Pop; Push(code); Push(temp); end; dc_loc: begin Push(code); if code^.r > maxLoc then maxLoc := code^.r; end; dc_prm: begin Push(code); if code^.s > maxLoc then maxLoc := code^.s; end; dc_str: begin Push(code); maxLoc := 0; end; dc_enp: begin Push(code); Reverse; Generate; end; otherwise: Error(cge1); {invalid opcode} end; {case} end; {DAG} end. \ No newline at end of file diff --git a/Exp.macros b/Exp.macros new file mode 100755 index 0000000..1d5e674 --- /dev/null +++ b/Exp.macros @@ -0,0 +1 @@ + MACRO &lab subroutine &parms,&work &lab anop aif c:&work,.a lclc &work &work setc 0 .a gbla &totallen gbla &worklen &worklen seta &work &totallen seta 0 aif c:&parms=0,.e lclc &len lclc &p lcla &i &i seta c:&parms .b &p setc &parms(&i) &len amid &p,2,1 aif "&len"=":",.c &len amid &p,1,2 &p amid &p,4,l:&p-3 ago .d .c &len amid &p,1,1 &p amid &p,3,l:&p-2 .d &p equ &totallen+3+&work &totallen seta &totallen+&len &i seta &i-1 aif &i,^b .e tsc sec sbc #&work tcs inc a phd tcd mend MACRO &lab return &r &lab anop lclc &len aif c:&r,.a lclc &r &r setc 0 &len setc 0 ago .h .a &len amid &r,2,1 aif "&len"=":",.b &len amid &r,1,2 &r amid &r,4,l:&r-3 ago .c .b &len amid &r,1,1 &r amid &r,3,l:&r-2 .c aif &len<>2,.d ldy &r ago .h .d aif &len<>4,.e ldx &r+2 ldy &r ago .h .e aif &len<>10,.g aif &totallen=0,.f lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .f pld tsc clc adc #&worklen+&totallen tcs phb plx ply lda &r+8 pha lda &r+6 pha lda &r+4 pha lda &r+2 pha lda &r pha phy phx plb rtl mexit .g mnote 'Not a valid return length',16 mexit .h aif &totallen=0,.i lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .i pld tsc clc adc #&worklen+&totallen tcs aif &len=0,.j tya .j rtl mend MACRO &LAB BGT &BP &LAB BEQ *+4 BGE &BP MEND MACRO &LAB BLE &BP &LAB BLT &BP BEQ &BP MEND MACRO &LAB MOVE4 &F,&T &LAB ~SETM LDA 2+&F STA 2+&T LDA &F STA &T ~RESTM MEND MACRO &LAB ~SETM &LAB ANOP AIF C:&~LA,.B GBLB &~LA GBLB &~LI .B &~LA SETB S:LONGA &~LI SETB S:LONGI AIF S:LONGA.AND.S:LONGI,.A REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) LONGA ON LONGI ON .A MEND MACRO &LAB ~RESTM &LAB ANOP AIF (&~LA+&~LI)=2,.I SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) AIF &~LA,.H LONGA OFF .H AIF &~LI,.I LONGI OFF .I MEND \ No newline at end of file diff --git a/Expression.asm b/Expression.asm new file mode 100755 index 0000000..dbf8ed1 --- /dev/null +++ b/Expression.asm @@ -0,0 +1 @@ + mcopy exp.macros **************************************************************** * * function lshr(x,y: longint): longint; * * Inputs: * num1 - number to shift * num2 - # bits to shift by * * Outputs: * A - result * **************************************************************** * lshr start subroutine (4:num1,4:num2),0 lda num2+2 if num2 < 0 then bpl lb2 cmp #$FFFF shift left bne zero ldx num2 cpx #-34 blt zero lb1 asl num1 rol num1+2 inx bne lb1 bra lb4 zero stz num1 (result is zero) stz num1+2 bra lb4 lb2 bne zero else shift right ldx num2 beq lb4 cpx #33 bge zero lb3 lsr num1+2 ror num1 dex bne lb3 lb4 lda 0 fix stack and return sta num2 lda 2 sta num2+2 return 4:num1 end **************************************************************** * * function udiv(x,y: longint): longint; * * Inputs: * num1 - numerator * num2 - denominator * * Outputs: * ans - result * **************************************************************** * udiv start ans equ 0 answer rem equ 4 remainder subroutine (4:num1,4:num2),8 ; ; Initialize ; stz rem rem = 0 stz rem+2 move4 num1,ans ans = num1 lda num2 check for division by zero ora num2+2 beq dv9 lda num2+2 do 16 bit divides separately ora ans+2 beq dv5 ; ; 32 bit divide ; ldy #32 32 bits to go dv3 asl ans roll up the next number rol ans+2 rol ans+4 rol ans+6 sec subtract for this digit lda ans+4 sbc num1 tax lda ans+6 sbc num2+2 bcc dv4 branch if minus stx ans+4 turn the bit on sta ans+6 inc ans dv4 dey next bit bne dv3 bra dv9 go do the sign ; ; 16 bit divide ; dv5 lda #0 initialize the remainder ldy #16 16 bits to go dv6 asl ans roll up the next number rol a sec subtract the digit sbc num2 bcs dv7 adc num2 digit is 0 dey bne dv6 bra dv8 dv7 inc ans digit is 1 dey bne dv6 dv8 sta ans+4 save the remainder ; ; Return the result ; dv9 return 4:ans move answer end **************************************************************** * * function uge(x,y: longint): cboolean; * **************************************************************** * uge start result equ 0 subroutine (4:x,4:y),4 stz result stz result+2 lda x+2 cmp y+2 bne lb1 lda x cmp y lb1 blt lb2 dec result dec result+2 lb2 return 2:result end **************************************************************** * * function ugt(x,y: longint): cboolean; * **************************************************************** * ugt start result equ 0 subroutine (4:x,4:y),4 stz result stz result+2 lda x+2 cmp y+2 bne lb1 lda x cmp y lb1 ble lb2 dec result dec result+2 lb2 return 2:result end **************************************************************** * * function ule(x,y: longint): cboolean; * **************************************************************** * ule start result equ 0 subroutine (4:x,4:y),4 stz result stz result+2 lda x+2 cmp y+2 bne lb1 lda x cmp y lb1 bgt lb2 dec result dec result+2 lb2 return 2:result end **************************************************************** * * function ult(x,y: longint): cboolean; * **************************************************************** * ult start result equ 0 subroutine (4:x,4:y),4 stz result stz result+2 lda x+2 cmp y+2 bne lb1 lda x cmp y lb1 bge lb2 dec result dec result+2 lb2 return 2:result end **************************************************************** * * function umod(x,y: longint): longint; * * Inputs: * num1 - numerator * num2 - denominator * * Outputs: * ans+4 - result * **************************************************************** * umod start ans equ 0 answer rem equ 4 remainder subroutine (4:num1,4:num2),8 ; ; Initialize ; stz rem rem = 0 stz rem+2 move4 num1,ans ans = num1 lda num2 check for division by zero ora num2+2 beq dv9 lda num2+2 do 16 bit divides separately ora ans+2 beq dv5 ; ; 32 bit divide ; ldy #32 32 bits to go dv3 asl ans roll up the next number rol ans+2 rol ans+4 rol ans+6 sec subtract for this digit lda ans+4 sbc num1 tax lda ans+6 sbc num2+2 bcc dv4 branch if minus stx ans+4 turn the bit on sta ans+6 inc ans dv4 dey next bit bne dv3 bra dv9 go do the sign ; ; 16 bit divide ; dv5 lda #0 initialize the remainder ldy #16 16 bits to go dv6 asl ans roll up the next number rol a sec subtract the digit sbc num2 bcs dv7 adc num2 digit is 0 dey bne dv6 bra dv8 dv7 inc ans digit is 1 dey bne dv6 dv8 sta ans+4 save the remainder ; ; Return the result ; dv9 return 4:ans+4 move answer end **************************************************************** * * function umul(x,y: longint): longint; * * Inputs: * num2,num1 - operands * * Outputs: * ans - result * **************************************************************** * umul start ans equ 0 answer subroutine (4:num1,4:num2),8 ; ; Initialize the sign and split on precision. ; stz ans+4 set up the multiplier stz ans+6 lda num1 sta ans lda num1+2 sta ans+2 beq ml3 branch if the multiplier is 16 bit ; ; Do a 32 bit by 32 bit multiply. ; ldy #32 32 bit multiply jsr ml1 brl ml7 ml1 lda ans SYSS1*SYSS1+2+SYSS1+2 -> SYSS1,SYSS1+2 lsr a bcc ml2 clc add multiplicand to the partial product lda ans+4 adc num2 sta ans+4 lda ans+6 adc num2+2 sta ans+6 ml2 ror ans+6 shift the interem result ror ans+4 ror ans+2 ror ans dey loop til done bne ml1 rts ; ; Do and 16 bit by 32 bit multiply. ; ml3 lda num2+2 branch if 16x16 is possible beq ml4 ldy #16 set up for 16 bits jsr ml1 do the multiply lda ans+2 move the answer sta ans lda ans+4 sta ans+2 bra ml7 ; ; Do a 16 bit by 16 bit multiply. ; ml4 ldy #16 set the 16 bit counter ldx ans move the low word stx ans+2 ml5 lsr ans+2 test the bit bcc ml6 branch if the bit is off clc adc num2 ml6 ror a shift the answer ror ans dey loop bne ml5 sta ans+2 save the high word ; ; Return the result. ; ml7 return 4:ans fix the stack end \ No newline at end of file diff --git a/Expression.pas b/Expression.pas new file mode 100755 index 0000000..1970ff8 --- /dev/null +++ b/Expression.pas @@ -0,0 +1 @@ +{$optimize 1} {---------------------------------------------------------------} { } { Expression } { } { Evaluate expressions } { } { Note: The expression evaluator uses the scanner to fetch } { tokens, but IT IS ALSO USED BY THE SCANNER to evaluate } { expressions in preprocessor commands. This circular } { dependency is handle by defining all of the expression } { evaluator's external types, constants, and variables in the } { CCOMMON module. The only procedure from this module used by } { the scanner is Expression, which is declared as an external } { procedure in the scanner. } { } { External Variables: } { } { startExpression - tokens that may start an expression } { bitDisp,bitSize - bit field disp, size } { unsigned - is the bit field unsigned? } { isBitField - is the field a bit field? } { } { External Subroutines: } { } { AssignmentConversion - do type checking and conversions for } { assignment statements } { CompareToZero - Compare the result on tos to zero. } { DisposeTree - dispose of an expression tree } { DoSelection - Find the displacement & type for a } { selection operation } { Expression - handle an expression } { FreeTemp - place a temporary label in the available label } { list } { GenerateCode - generate code from a fully formed expression } { tree } { GetTemp - find a temporary work variable } { InitExpression - initlialize the expression handler } { UsualBinaryConversions - performs the usual binary } { conversions } { UsualUnaryConversions - performs the usual unary conversions } { } {---------------------------------------------------------------} unit Expression; {$LibPrefix '0/obj/'} interface uses CCommon, Table, CGI, Scanner, Symbol, MM; {$segment 'exp'} var startExpression: tokenSet; {tokens that can start an expression} {set by DoSelection} {------------------} bitDisp,bitSize: integer; {bit field disp, size} unsigned: boolean; {is the bit field unsigned?} isBitField: boolean; {is the field a bit field?} {misc} {----} lastwasconst: boolean; {did the last GenerateCode result in an integer constant?} lastconst: longint; {last integer constant from GenerateCode} {---------------------------------------------------------------} procedure AssignmentConversion (t1, t2: typePtr; isConstant: boolean; value: longint; genCode, checkConst: boolean); { TOS is of type t2, and is about to be stored to a variable of } { type t1 by an assignment or a return statement. Make sure } { this is legal, and do any necessary type conversions on t2, } { which is on the top of the evaluation stack. Flag an error } { if the conversion is illegal. } { } { parameters: } { t1 - type of the variable } { t2 - type of the expression } { isConstant - is the rhs a constant? } { value - if isConstant = true, then this is the value } { genCode - should conversion code be generated? } { checkConst - check for assignments to constants? } procedure CompareToZero(op: pcodes); { Compare the result on tos to zero. } { } { This procedure is used by the logical statements to compare } { _any_ scalar result to zero, giving a boolean result. } { } { parameters: } { op - operation to use on the compare } procedure DisposeTree (tree: tokenPtr); { dispose of an expression tree } { } { parameters: } { tree - head of the expression tree to dispose of } procedure DoSelection (lType: typePtr; tree: tokenPtr; var size: longint); { Find the displacement & type for a selection operation } { } { parameters: } { lType - structure/union type } { id - tag field name } { size - disp into the structure/union } { } { returned in non-local variables: } { bitDisp - displacement to bit field } { bitSize - size of bit field } { unsigned - is the bit field unsigned? } { isBitField - is the field a bit field? } { } { varaibles: } { expressionType - set to the type of the field } procedure Expression (kind: expressionKind; stopSym: tokenSet); { handle an expression } { } { parameters: } { kind - Kind of expression; determines what operations } { and what kind of operands are allowed. } { stopSym - Set of symbols that can mark the end of an } { expression; used to skip tokens after syntax } { errors and to block certain operations. For } { example, the comma operator is not allowed in } { an expression when evaluating a function } { parameter list. } { } { variables: } { realExpressionValue - value of a real constant } { expression } { expressionValue - value of a constant expression } { expressionType - type of the constant expression } procedure FreeTemp(labelNum, size: integer); { place a temporary label in the available label list } { } { parameters: } { labelNum - number of the label to free } { size - size of the variable } { } { variables: } { tempList - list of free labels } procedure GenerateCode (tree: tokenPtr); { generate code from a fully formed expression tree } { } { parameters: } { tree - top of the expression tree to generate code from } { } { variables: } { expressionType - result type of the expression } function GetTemp(size: integer): integer; { find a temporary work variable } { } { parameters: } { size - size of the variable } { } { variables: } { tempList - list of free labels } { } { Returns the label number. } procedure InitExpression; { initialize the expression handler } function UsualBinaryConversions (lType: typePtr): baseTypeEnum; { performs the usual binary conversions } { } { inputs: } { lType - type of the left operand } { expressionType - type of the right operand } { } { result: } { The base type of the operation to perform is } { returned. Any conversion code necessary has been } { generated. } { } { outputs: } { expressionType - set to result type } function UsualUnaryConversions: baseTypeEnum; { performs the usual unary conversions } { } { inputs: } { expressionType - type of the operand } { } { result: } { The base type of the operation to perform is returned. } { Any conversion code necessary has been generated. } { } { outputs: } { expressionType - set to result type } {---------------------------------------------------------------} implementation const {notAnOperation is also used in TABLE.ASM} notAnOperation = 200; {used as the icp for non-operation tokens} var {structured constants} {--------------------} startTerm: tokenSet; {tokens that can start a term} {misc} {----} errorFound: boolean; {was there are error during generation?} {-- Procedures imported from the parser ------------------------} procedure Match (kind: tokenEnum; err: integer); extern; { insure that the next token is of the specified type } { } { parameters: } { kind - expected token kind } { err - error number if the expected token is not found } procedure TypeSpecifier (doingFieldList,isConstant: boolean); extern; { handle a type specifier } { } { parameters: } { doingFieldList - are we processing a field list? } { isConstant - did we already find a constsy? } {-- External unsigned math routines ----------------------------} function lshr (x,y: longint): longint; extern; function udiv (x,y: longint): longint; extern; function uge (x,y: longint): longint; extern; function ugt (x,y: longint): longint; extern; function ule (x,y: longint): longint; extern; function ult (x,y: longint): longint; extern; function umod (x,y: longint): longint; extern; function umul (x,y: longint): longint; extern; {---------------------------------------------------------------} function Unary(tp: baseTypeEnum): baseTypeEnum; { usual unary conversions } { } { This function returns the base type actually loaded on the } { stack for a particular data type. This corresponds to C's } { usual unary conversions. } { } { parameter: } { tp - data type } { } { result: } { Stack type. } begin {Unary} if tp in [cgByte,cgUByte,cgReal,cgDouble,cgComp] then if tp = cgByte then tp := cgWord else if tp = cgUByte then tp := cgUWord else {if tp in [cgReal,cgDouble,cgComp] then} tp := cgExtended; Unary := tp; end; {Unary} function UsualBinaryConversions {lType: typePtr): baseTypeEnum}; { performs the usual binary conversions } { } { inputs: } { lType - type of the left operand } { expressionType - type of the right operand } { } { result: } { The base type of the operation to perform is } { returned. Any conversion code necessary has been } { generated. } { } { outputs: } { expressionType - set to result type } var rType: typePtr; {right type} lt,rt: baseTypeEnum; {work variables} begin {UsualBinaryConversions} UsualBinaryConversions := cgULong; if lType^.kind = pointerType then lType := uLongPtr else if lType^.kind = scalarType then if lType^.baseType = cgVoid then lType := uLongPtr; rType := expressionType; if rType^.kind = pointerType then rType := uLongPtr else if rType^.kind = scalarType then if rType^.baseType = cgVoid then rType := uLongPtr; if (lType^.kind = scalarType) and (rType^.kind = scalarType) then begin lt := Unary(lType^.baseType); rt := Unary(rType^.baseType); if lt <> rt then begin if lt = cgExtended then begin if rt in [cgWord,cgUWord,cgLong,cgULong] then Gen2(pc_cnv, ord(rt), ord(cgExtended)); UsualBinaryConversions := cgExtended; expressionType := extendedPtr; end {if} else if rt = cgExtended then begin if lt in [cgWord,cgUWord,cgLong,cgULong] then Gen2(pc_cnn, ord(lt), ord(cgExtended)); UsualBinaryConversions := cgExtended; expressionType := extendedPtr; end {else if} else if lt = cgULong then begin if rt in [cgWord,cgUWord] then Gen2(pc_cnv, ord(rt), ord(cgULong)); UsualBinaryConversions := cgULong; expressionType := uLongPtr; end {else if} else if rt = cgULong then begin if lt in [cgWord,cgUWord] then Gen2(pc_cnn, ord(lt), ord(cgULong)); UsualBinaryConversions := cgULong; expressionType := uLongPtr; end {else if} else if lt = cgLong then begin if rt in [cgWord,cgUWord] then Gen2(pc_cnv, ord(rt), ord(cgLong)); UsualBinaryConversions := cgLong; expressionType := longPtr; end {else if} else if rt = cgLong then begin if lt in [cgWord,cgUWord] then Gen2(pc_cnn, ord(lt), ord(cgLong)); UsualBinaryConversions := cgLong; expressionType := longPtr; end {else if} else {one operand is unsigned in and the other is int} begin UsualBinaryConversions := cgUWord; expressionType := uWordPtr; end; {else} end {if} else {types are the same} UsualBinaryConversions := lt; end {if} else Error(66); end; {UsualBinaryConversions} function UsualUnaryConversions{: baseTypeEnum}; { performs the usual unary conversions } { } { inputs: } { expressionType - type of the operand } { } { result: } { The base type of the operation to perform is returned. } { Any conversion code necessary has been generated. } { } { outputs: } { expressionType - set to result type } var lt,rt: baseTypeEnum; {work variables} begin {UsualUnaryConversions} UsualUnaryConversions := cgULong; if expressionType^.kind = scalarType then UsualUnaryConversions := Unary(expressionType^.baseType) {else if expressionType^.kind in [arrayType,pointerType] then UsualUnaryConversions := cgULong}; end; {UsualUnaryConversions} procedure DisposeTree {tree: tokenPtr}; { dispose of an expression tree } { } { parameters: } { tree - head of the expression tree to dispose of } begin {DisposeTree} if tree <> nil then begin DisposeTree(tree^.left); DisposeTree(tree^.middle); DisposeTree(tree^.right); dispose(tree); end; {if} end; {DisposeTree} procedure AssignmentConversion {t1, t2: typePtr; isConstant: boolean; value: longint; genCode, checkConst: boolean}; { TOS is of type t2, and is about to be stored to a variable of } { type t1 by an assignment or a return statement. Make sure } { this is legal, and do any necessary type conversions on t2, } { which is on the top of the evaluation stack. Flag an error } { if the conversion is illegal. } { } { parameters: } { t1 - type of the variable } { t2 - type of the expression } { isConstant - is the rhs a constant? } { value - if isConstant = true, then this is the value } { genCode - should conversion code be generated? } { checkConst - check for assignments to constants? } var baseType1,baseType2: baseTypeEnum; {temp variables (for speed)} kind1,kind2: typeKind; {temp variables (for speed)} begin {AssignmentConversion} kind1 := t1^.kind; kind2 := t2^.kind; if t1^.isConstant then if genCode then if checkConst then Error(93); if kind2 = definedType then AssignmentConversion(t1, t2^.dType, false, 0, genCode, checkConst) else if kind1 = definedType then AssignmentConversion(t1^.dType, t2, false, 0, genCode, checkConst) else if kind2 in [scalarType,pointerType,enumType,structType,unionType,arrayType,functionType] then case kind1 of scalarType: begin baseType1 := t1^.baseType; if baseType1 = cgString then Error(64) else if baseType1 = cgVoid then Error(65) else if kind2 = enumType then begin if genCode then Gen2(pc_cnv, ord(cgWord), ord(baseType1)); end {else if} else if kind2 = scalarType then begin baseType2 := t2^.baseType; if baseType2 in [cgString,cgVoid] then Error(47) else if genCode then Gen2(pc_cnv, ord(baseType2), ord(baseType1)); end {else if} else Error(47); end; arrayType: ; {any errors are handled elsewhere} functionType,enumConst: Error(47); pointerType: begin if kind2 = pointerType then begin if not CompTypes(t1, t2) then Error(47); end {if} else if kind2 = arrayType then begin if not CompTypes(t1^.ptype, t2^.atype) then if t1^.ptype^.baseType <> cgVoid then Error(47); end {if} else if kind2 = scalarType then begin if isConstant and (value = 0) then begin if genCode then Gen2(pc_cnv, ord(t2^.baseType), ord(cgULong)); end {if} else Error(47); end {else if} else Error(47); end; enumType: begin if kind2 = scalarType then begin baseType2 := t2^.baseType; if baseType2 in [cgString,cgVoid] then Error(47) else if genCode then Gen2(pc_cnv, ord(baseType2), ord(cgWord)); end {if} else if kind2 <> enumType then Error(47); end; definedType: AssignmentConversion(t1^.dType, t2, isConstant, value, genCode, checkConst); structType,unionType: if not CompTypes(t1, t2) then Error(47); otherwise: Error(57); end; {case T1^.kind} expressionType := t1; {set the type of the expression} end; {AssignmentConversion} function ExpressionTree (kind: expressionKind; stopSym: tokenSet): tokenPtr; { generate an expression tree } { } { Returns a pointer to the generated tree. The pointer is } { nil, and the variable errorFound is set to true, if an } { error is found. } { } { parameters: } { kind - Kind of expression; determines what operations } { and what kind of operands are allowed. } { stopSym - Set of symbols that can mark the end of an } { expression; used to skip tokens after syntax } { errors and to block certain operations. For } { example, the comma operator is not allowed in } { an expression when evaluating a function } { parameter list. } label 1,2; var done,done2: boolean; {for loop termination} doingSizeof: boolean; {used to test for a sizeof operator} expectingTerm: boolean; {should the next token be a term?} opStack: tokenPtr; {operation stack} parenCount: integer; {# of open parenthesis} stack: tokenPtr; {operand stack} op,sp: tokenPtr; {work pointers} procedure ComplexTerm; { handle complex terms } var done: boolean; {for loop termination} namePtr: stringPtr; {name of struct/union fields} sp,tp,tm: tokenPtr; {work pointers} begin {ComplexTerm} while token.kind in [lbrackch,lparench,dotch,minusgtop,plusplusop,minusminusop] do begin case token.kind of lbrackch: begin {subscripting} NextToken; {skip the '['} new(sp); {evaluate the subscript} sp^.token.kind := plusch; sp^.token.class := reservedSymbol; sp^.left := stack; stack := stack^.next; sp^.middle := nil; sp^.right := ExpressionTree(normalExpression, [rbrackch]); sp^.next := stack; stack := sp; Match(rbrackch,24); {skip the ']'} new(sp); {resolve the pointer} sp^.token.kind := uasterisk; sp^.token.class := reservedSymbol; sp^.left := stack; sp^.middle := nil; sp^.right := nil; sp^.next := stack^.next; stack := sp; end; lparench: begin {function call} NextToken; new(sp); {create a parameter list terminator} sp^.token.kind := parameteroper; sp^.token.class := reservedSymbol; sp^.left := nil; sp^.middle := nil; sp^.right := nil; sp^.next := stack; stack := sp; if token.kind <> rparench {evaluate the parameters} then begin done := false; repeat if token.kind in [rparench,eofsy] then begin done := true; Error(35); end {if} else begin new(sp); sp^.token.kind := parameteroper; sp^.token.class := reservedSymbol; sp^.left := nil; sp^.middle := ExpressionTree(normalExpression, [rparench,commach]); sp^.right := stack; sp^.next := stack^.next; stack := sp; if token.kind = commach then NextToken else done := true; end; {else} until done; end; {if} sp := stack; stack := sp^.next; sp^.left := stack; sp^.next := stack^.next; stack := sp; Match(rparench,12); end; dotch,minusgtop: begin {direct and indirect selection} if token.kind = minusgtop then begin new(sp); {e->name == (*e).name} sp^.token.kind := uasterisk; sp^.token.class := reservedSymbol; sp^.left := stack; sp^.middle := nil; sp^.right := nil; sp^.next := stack^.next; stack := sp; token.kind := dotch; token.class := reservedSymbol; end; {if} new(sp); {create a record for the selection operator} sp^.token := token; sp^.left := stack; stack := stack^.next; sp^.middle := nil; sp^.right := nil; sp^.next := stack; stack := sp; NextToken; {skip the operator} if token.kind in [ident,typedef] then begin namePtr := token.name; {record the name} new(sp); {record the selection field} sp^.token := token; sp^.left := nil; sp^.middle := nil; sp^.right := nil; stack^.right := sp; {this becomes the right opnd} NextToken; {skip the field name} end {if} else Error(9); end; plusplusop: begin {postfix ++} NextToken; new(sp); sp^.token.kind := opplusplus; sp^.token.class := reservedSymbol; sp^.left := stack; stack := stack^.next; sp^.middle := nil; sp^.right := nil; sp^.next := stack; stack := sp; end; minusminusop: begin {postfix --} NextToken; new(sp); sp^.token.kind := opminusminus; sp^.token.class := reservedSymbol; sp^.left := stack; stack := stack^.next; sp^.middle := nil; sp^.right := nil; sp^.next := stack; stack := sp; end; otherwise: Error(57); end; {case} end; {while} end; {ComplexTerm} procedure DoOperand; { process an operand } label 1,2; var fnPtr: typePtr; {for defining functions on the fly} fToken: tokenType; {used to save function name token} id: identPtr; {pointer to an id's symbol table entry} np: stringPtr; {for forming global names} sp: tokenPtr; {work pointer} begin {DoOperand} {create an operand on the stack} new(sp); sp^.token := token; sp^.next := stack; sp^.left := nil; sp^.middle := nil; sp^.right := nil; stack := sp; {handle the preprocessor 'defined' function} if kind = preprocessorExpression then if token.name^ = 'defined' then begin expandMacros := false; NextToken; sp^.token.kind := intconst; sp^.token.class := intConstant; if token.kind in [ident,typedef] then begin sp^.token.ival := ord(IsDefined(token.name)); NextToken; end {if} else begin Match(lparench, 13); if token.kind in [ident,typedef] then begin sp^.token.ival := ord(IsDefined(token.name)); NextToken; end {if} else begin Error(9); sp^.token.ival := 0; end; {else} Match(rparench, 12); end; {else} expandMacros := true; goto 1; end; {if} {check for illegal use} id := FindSymbol(token, variableSpace, false, true); if not (kind in [normalExpression,initializerExpression,autoInitializerExpression]) then begin if id <> nil then if id^.itype^.kind = enumConst then goto 2; if kind <> preprocessorExpression then begin op := opStack; while op <> nil do begin if op^.token.kind = sizeofsy then goto 2; op := op^.next; end; {while} Error(41); errorFound := true; end; {if} end; {if} 2: {skip the name} fToken := token; NextToken; {if the id is not declared, create a function returning integer} if id = nil then begin if token.kind = lparench then begin fnPtr := pointer(GCalloc(sizeof(typeRecord))); {fnPtr^.size := 0;} {fnPtr^.saveDisp := 0;} {fnPtr^.isConstant := false;} fnPtr^.kind := functionType; fnPtr^.fType := wordPtr; {fnPtr^.varargs := false;} {fnPtr^.prototyped := false;} {fnPtr^.overrideKR := false;} {fnPtr^.parameterList := nil;} {fnPtr^.isPascal := false;} {fnPtr^.toolNum := 0;} {fnPtr^.dispatcher := 0;} np := pointer(GMalloc(length(fToken.name^)+1)); CopyString(pointer(np), pointer(fToken.name)); id := NewSymbol(np, fnPtr, ident, variableSpace, declared); if (lint & lintUndefFn) <> 0 then Error(51); end {if} else if kind = preprocessorExpression then begin stack^.token.kind := intconst; stack^.token.ival := 0; end {else if} else begin Error(31); errorFound := true; end; {else} end {if id = nill} else if id^.itype^.kind = enumConst then begin stack^.token.kind := intconst; stack^.token.ival := id^.itype^.eval; end; {else if} stack^.id := id; {save the identifier} ComplexTerm; {handle subscripts, selection, etc.} 1: end; {DoOperand} procedure Operation; { do an operation } label 1; var baseType: baseTypeEnum; {base type of value to cast} class: tokenClass; {class of cast token} ekind: tokenEnum; {kind of constant expression} kindLeft, kindRight: tokenEnum; {kinds of operands} lCodeGeneration: boolean; {local copy of codeGeneration} op: tokenPtr; {work pointer} op1,op2: longint; {for evaluating constant expressions} rop1,rop2: double; {for evaluating double expressions} tp: typePtr; {cast type} unsigned, unsigned1: boolean; {is the term unsigned?} function Pop: tokenPtr; { pop an operand, returning its pointer } begin {Pop} if stack = nil then begin Error(36); errorFound := true; Pop := nil; end {if} else begin Pop := stack; stack := stack^.next; end; {else} end; {Pop} function RealVal (token: tokenType): double; { convert an operand to a real value } begin {RealVal} if token.kind = intconst then RealVal := token.ival else if token.kind = uintconst then begin if token.ival < 0 then RealVal := (token.ival & $7FFF) + 32768.0 else RealVal := token.ival; end {else if} else if token.kind = longconst then RealVal := token.lval else if token.kind = ulongconst then begin if token.lval < 0 then RealVal := (token.lval & $7FFFFFFF) + 2147483648.0 else RealVal := token.lval; end {else if} else RealVal := token.rval; end; {RealVal} function IntVal (token: tokenType): longint; { convert an operand to a longint value } begin {IntVal} if token.kind = intconst then IntVal := token.ival else if token.kind = uintconst then begin IntVal := token.ival & $0000FFFF; unsigned := true; end {else if} else if token.kind = longconst then begin IntVal := token.lval; ekind := longconst; end {else if} else begin IntVal := token.lval; ekind := longconst; unsigned := true; end; {else} end; {IntVal} begin {Operation} op := opStack; {pop the operation} opStack := op^.next; case op^.token.kind of commach: begin {,} op^.right := Pop; op^.left := Pop; end; eqch, {=} pluseqop, {+=} minuseqop, {-=} asteriskeqop, {*=} slasheqop, {/=} percenteqop, {%=} ltlteqop, {<<=} gtgteqop, {>>=} andeqop, {&=} caroteqop, {^=} bareqop: begin {|=} op^.right := Pop; op^.left := Pop; end; colonch: begin {? :} op^.right := Pop; op^.middle := Pop; op^.left := Pop; if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst] then if op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst] then if op^.middle^.token.kind in [intconst,uintconst,longconst,ulongconst] then begin if IntVal(op^.left^.token) <> 0 then op^.token := op^.middle^.token else op^.token := op^.right^.token; dispose(op^.left); dispose(op^.right); dispose(op^.middle); op^.left := nil; op^.right := nil; op^.middle := nil; end; {if} end; questionch: begin {error -> ? should not be unmatched} Error(29); errorFound := true; end; barbarop, {||} andandop, {&&} carotch, {^} barch, {|} andch, {&} eqeqop, {==} exceqop, {!=} ltch, {<} gtch, {>} lteqop, {<=} gteqop, {>=} ltltop, {<<} gtgtop, {>>} plusch, {+} minusch, {-} asteriskch, {*} slashch, {/} percentch: begin {%} op^.right := Pop; op^.left := Pop; kindRight := op^.right^.token.kind; kindLeft := op^.left^.token.kind; if kindRight in [intconst,uintconst,longconst,ulongconst] then begin if kindLeft in [intconst,uintconst,longconst,ulongconst] then begin {do the usual binary conversions} if (kindRight = ulongconst) or (kindLeft = ulongconst) then ekind := ulongconst else if (kindRight = longconst) or (kindLeft = longconst) then ekind := longconst else if (kindRight = uintconst) or (kindLeft = uintconst) then ekind := uintconst else ekind := intconst; {evaluate a constant operation} unsigned := false; op1 := IntVal(op^.left^.token); unsigned1 := unsigned; unsigned := false; op2 := IntVal(op^.right^.token); unsigned := unsigned or unsigned1; dispose(op^.right); op^.right := nil; dispose(op^.left); op^.left := nil; case op^.token.kind of barbarop : {||} op1 := ord((op1 <> 0) or (op2 <> 0)); andandop : {&&} op1 := ord((op1 <> 0) and (op2 <> 0)); carotch : op1 := op1 ! op2; {^} barch : op1 := op1 | op2; {|} andch : op1 := op1 & op2; {&} eqeqop : begin {==} op1 := ord(op1 = op2); ekind := intconst; end; exceqop : begin {!=} op1 := ord(op1 <> op2); ekind := intconst; end; ltch : begin {<} if unsigned then op1 := ult(op1,op2) else op1 := ord(op1 < op2); ekind := intconst; end; gtch : begin {>} if unsigned then op1 := ugt(op1,op2) else op1 := ord(op1 > op2); ekind := intconst; end; lteqop : begin {<=} if unsigned then op1 := ule(op1,op2) else op1 := ord(op1 <= op2); ekind := intconst; end; gteqop : begin {>=} if unsigned then op1 := uge(op1,op2) else op1 := ord(op1 >= op2); ekind := intconst; end; ltltop : op1 := op1 << op2; {<<} gtgtop : if unsigned1 then {>>} op1 := lshr(op1,op2) else op1 := op1 >> op2; plusch : op1 := op1 + op2; {+} minusch : op1 := op1 - op2; {-} asteriskch : if unsigned then {*} op1 := umul(op1,op2) else op1 := op1 * op2; slashch : begin {/} if op2 = 0 then begin Error(109); op2 := 1; end; {if} if unsigned then op1 := udiv(op1,op2) else op1 := op1 div op2; end; percentch : begin {%} if op2 <= 0 then begin Error(109); op2 := 1; end; {if} if unsigned then op1 := umod(op1,op2) else op1 := op1 mod op2; end; otherwise: Error(57); end; {case} op^.token.kind := ekind; if ekind in [longconst,ulongconst] then begin op^.token.lval := op1; op^.token.class := longConstant; end {if} else begin op^.token.ival := long(op1).lsw; op^.token.class := intConstant; end; {else} goto 1; end; {if} end; {if} if op^.right^.token.kind in [intconst,uintconst,longconst,ulongconst,doubleconst] then if op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst,doubleconst] then begin ekind := doubleconst; {evaluate a constant operation} rop1 := RealVal(op^.left^.token); rop2 := RealVal(op^.right^.token); dispose(op^.right); op^.right := nil; dispose(op^.left); op^.left := nil; case op^.token.kind of barbarop : {||} rop1 := ord((rop1 <> 0.0) or (rop2 <> 0.0)); andandop : {&&} rop1 := ord((rop1 <> 0.0) and (rop2 <> 0.0)); eqeqop : begin {==} op1 := ord(rop1 = rop2); ekind := intconst; end; exceqop : begin {!=} op1 := ord(rop1 <> rop2); ekind := intconst; end; ltch : begin {<} op1 := ord(rop1 < rop2); ekind := intconst; end; gtch : begin {>} op1 := ord(rop1 > rop2); ekind := intconst; end; lteqop : begin {<=} op1 := ord(rop1 <= rop2); ekind := intconst; end; gteqop : begin {>=} op1 := ord(rop1 >= rop2); ekind := intconst; end; plusch : rop1 := rop1 + rop2; {+} minusch : rop1 := rop1 - rop2; {-} asteriskch : rop1 := rop1 * rop2; {*} slashch : begin {/} if rop2 = 0.0 then begin Error(109); rop2 := 1.0; end; {if} rop1 := rop1 / rop2; end; otherwise : Error(66); {illegal operation} end; {case} if ekind = intconst then begin op^.token.ival := long(op1).lsw; op^.token.class := intConstant; op^.token.kind := intConst; end {if} else begin op^.token.rval := rop1; op^.token.class := doubleConstant; op^.token.kind := doubleConst; end; {else} end; {if} 1: end; plusplusop, {prefix ++} minusminusop, {prefix --} opplusplus, {postfix ++} opminusminus, {postfix --} sizeofsy, {sizeof} castoper, {(type)} typedef, {(type-name)} tildech, {~} excch, {!} uminus, {unary -} uand, {unary &} uasterisk: begin {unary *} op^.left := Pop; if op^.token.kind = sizeofsy then begin op^.token.kind := longConst; op^.token.class := longConstant; if op^.left^.token.kind = stringConst then op^.token.lval := op^.left^.token.sval^.length+1 else begin lCodeGeneration := codeGeneration; codeGeneration := false; GenerateCode(op^.left); codeGeneration := lCodeGeneration and (numErrors = 0); op^.token.lval := expressionType^.size; with expressionType^ do if kind = arrayType then if (elements = 0) or (size = 0) then Error(49); end; {else} op^.left := nil; end {if sizeofsy} else if op^.token.kind = castoper then begin class := op^.left^.token.class; if class in [intConstant,longConstant,doubleConstant] then begin tp := op^.castType; while tp^.kind = definedType do tp := tp^.dType; if tp^.kind = scalarType then begin baseType := tp^.baseType; if baseType < cgString then begin if class = doubleConstant then begin rop1 := RealVal(op^.left^.token); op1 := trunc(rop1); end {if} else {if class in [intConstant,longConstant] then} begin op1 := IntVal(op^.left^.token); if op1 >= 0 then rop1 := op1 else if op^.left^.token.kind = uintConst then rop1 := (op1 & $7FFF) + 32768.0 else if op^.left^.token.kind = ulongConst then rop1 := (op1 & $7FFFFFFF) + 2147483648.0 else rop1 := op1; end; {else if} dispose(op^.left); op^.left := nil; if baseType in [cgByte,cgWord] then begin op^.token.kind := intConst; op^.token.class := intConstant; op^.token.ival := long(op1).lsw; if baseType = cgByte then with op^.token do begin ival := ival & $00FF; if (ival & $0080) <> 0 then ival := ival | $FF00; end; {with} end {if} else if baseType in [cgUByte,cgUWord] then begin op^.token.kind := uintConst; op^.token.class := intConstant; op^.token.ival := long(op1).lsw; if baseType = cgUByte then op^.token.ival := op^.token.ival & $00FF; end {else if} else if baseType = cgLong then begin op^.token.kind := longConst; op^.token.class := longConstant; op^.token.lval := op1; end {else if} else if baseType = cgULong then begin op^.token.kind := ulongConst; op^.token.class := longConstant; op^.token.lval := op1; end {else if} else begin op^.token.kind := doubleConst; op^.token.class := doubleConstant; op^.token.rval := rop1; end; {else if} end; {if} end; {if} end; {if} end {else if castoper} else if not (op^.token.kind in [typedef,plusplusop,minusminusop,opplusplus,opminusminus,uand]) then begin if (op^.left^.token.kind in [intconst,uintconst,longconst,ulongconst]) then begin {evaluate a constant operation} ekind := op^.left^.token.kind; op1 := IntVal(op^.left^.token); dispose(op^.left); op^.left := nil; case op^.token.kind of opplusplus, {posfix ++} plusplusop : op1 := op1+1; {prefix ++} opminusminus, {postfix --} minusminusop: op1 := op1-1; {prefix --} tildech : op1 := ~op1; {~} excch : begin {!} op1 := ord(op1 = 0); ekind := intconst; end; uminus : op1 := -op1; {unary -} uand : op1 := 0; {unary &} uasterisk : op1 := 0; {unary *} otherwise: Error(57); end; {case} op^.token.kind := ekind; if ekind in [longconst,ulongconst] then begin op^.token.class := longConstant; op^.token.lval := op1; end {if} else begin op^.token.class := intConstant; op^.token.ival := long(op1).lsw; end; {else} end {if} else if op^.left^.token.kind = doubleconst then begin ekind := doubleconst; {evaluate a constant operation} rop1 := RealVal(op^.left^.token); dispose(op^.left); op^.left := nil; case op^.token.kind of uminus : begin {unary -} op^.token.class := doubleConstant; op^.token.kind := doubleConst; op^.token.rval := -rop1; end; otherwise : begin {illegal operation} Error(66); op^.token.class := doubleConstant; op^.token.kind := doubleConst; op^.token.rval := rop1; end; end; {case} end; {if} end; {if} end; otherwise: Error(57); end; {case} op^.next := stack; {place the operation on the operand stack} stack := op; end; {Operation} procedure Skip; { skip all tokens in the reminader of the expression } begin {Skip} while not (token.kind in stopSym+[eofsy]) do NextToken; errorFound := true; end; {Skip} procedure TypeName; { find the type (used for casts and sizeof) } { } { outputs: } { typeSpec - pointer to the type } var tl,tp: typePtr; {for creating/reversing the type list} procedure AbstractDeclarator; { process an abstract declarator } { } { abstract-declarator: } { empty-abstract-declarator } { nonempty-abstract-declarator } procedure NonEmptyAbstractDeclarator; { process a nonempty abstract declarator } { } { nonempty-abstract-declarator: } { ( nonempty-abstract-declarator ) } { abstract-declarator ( ) } { abstract-declaraotr [ expression OPT ] } { * abstract-declarator } var pcount: integer; {paren counter} tp: typePtr; {work pointer} begin {NonEmptyAbstractDeclarator} if token.kind = lparench then begin NextToken; if token.kind = rparench then begin {create a function type} tp := pointer(Calloc(sizeof(typeRecord))); {tp^.size := 0;} {tp^.saveDisp := 0;} {tp^.isConstant := false;} tp^.kind := functionType; {tp^.varargs := false;} {tp^.prototyped := false;} {tp^.overrideKR := false;} {tp^.parameterList := nil;} {tp^.isPascal := false;} {tp^.toolNum := 0;} {tp^.dispatcher := 0;} tp^.fType := tl; tl := tp; NextToken; end {if} else begin {handle a perenthesized type} if not (token.kind in [lparench,asteriskch,lbrackch]) then begin Error(82); while not (token.kind in [eofsy,lparench,asteriskch,lbrackch,rparench]) do NextToken; errorFound := true; end; {if} if token.kind in [lparench,asteriskch,lbrackch] then NonEmptyAbstractDeclarator; Match(rparench,12); end; {else} end {if token.kind = lparench} else if token.kind = asteriskch then begin {create a pointer type} NextToken; AbstractDeclarator; tp := pointer(Malloc(sizeof(typeRecord))); tp^.size := cgLongSize; tp^.saveDisp := 0; tp^.isConstant := false; tp^.kind := pointerType; tp^.fType := tl; tl := tp; end {else if token.kind = asteriskch} else {if token.kind = lbrackch then} begin {create an array type} NextToken; if token.kind = rbrackch then expressionValue := 0 else begin Expression(arrayExpression, [rbrackch]); if expressionValue <= 0 then begin Error(45); expressionValue := 1; end; {if} end; {else} tp := pointer(Malloc(sizeof(typeRecord))); tp^.saveDisp := 0; tp^.kind := arrayType; tp^.elements := expressionValue; tp^.fType := tl; tl := tp; Match(rbrackch,24); end; {else} if token.kind = lparench then begin {create a function type} NextToken; pcount := 1; while (token.kind <> eofsy) and (pcount <> 0) do begin if token.kind = rparench then pcount := pcount-1 else if token.kind = lparench then pcount := pcount+1; NextToken; end; {while} tp := pointer(Calloc(sizeof(typeRecord))); {tp^.size := 0;} {tp.saveDisp := 0;} {tp^.isConstant := false;} tp^.kind := functionType; {tp^.varargs := false;} {tp^.prototyped := false;} {tp^.overrideKR := false;} {tp^.parameterList := nil;} {tp^.isPascal := false;} {tp^.toolNum := 0;} {tp^.dispatcher := 0;} tp^.fType := tl; tl := tp; end; {if} end; {NonEmptyAbstractDeclarator} begin {AbstractDeclarator} while token.kind in [lparench,asteriskch,lbrackch] do NonEmptyAbstractDeclarator; end; {AbstractDeclarator} begin {TypeName} {read and process the type specifier} typeSpec := wordPtr; TypeSpecifier(false,false); {handle the abstract-declarator part} tl := nil; {no types so far} AbstractDeclarator; {create the type list} while tl <> nil do begin {reverse the list & compute array sizes} tp := tl^.aType; {NOTE: assumes aType, pType and fType overlap in typeRecord} tl^.aType := typeSpec; if tl^.kind = arrayType then tl^.size := tl^.elements * typeSpec^.size; typeSpec := tl; tl := tp; end; {while} end; {TypeName} begin {ExpressionTree} opStack := nil; stack := nil; if token.kind = typedef then {handle typedefs that are hidden} if FindSymbol(token,allSpaces,false,true) <> nil then if token.symbolPtr^.class <> typedefsy then token.kind := ident; if token.kind in startExpression then begin expressionValue := 0; {initialize the expression value} expectingTerm := true; {the first item should be a term} done := false; {convert the expression to postfix form} parenCount := 0; repeat {scan the token list...} if token.kind in startTerm then begin {we must expect a term or unary operand} if not expectingTerm then begin Error(36); Skip; goto 1; end; {if} if token.kind = ident then {handle a complex operand} DoOperand else begin {handle a constant operand} new(sp); sp^.token := token; sp^.next := stack; sp^.left := nil; sp^.middle := nil; sp^.right := nil; stack := sp; if kind in [preprocessorExpression,arrayExpression] then if token.kind in [stringconst,doubleconst] then begin Error(41); errorFound := true; end; {if} NextToken; ComplexTerm; end; {else} expectingTerm := false; {the next thing should be an operation} end {else} {handle a closing parenthesis} else if (token.kind = rparench) and (parenCount > 0) then begin if expectingTerm then begin {make sure it is in a legal spot} Error(37); Skip; goto 1; end; {if} while opStack^.token.kind <> lparench do Operation; {do pending operations} op := opStack; opStack := op^.next; dispose(op); parenCount := parenCount-1; NextToken; {skip the ')'} ComplexTerm; {handle subscripts, selection, etc.} end {else} else if token.kind = lparench then begin {handle open paren and type casts} if not expectingTerm then begin Error(38); Skip; goto 1; end; {if} NextToken; if token.kind in [unsignedsy,intsy,longsy,charsy,shortsy,floatsy, doublesy,compsy,extendedsy,voidsy,enumsy,structsy,unionsy, typedef,constsy,volatilesy,signedsy] then begin doingSizeof := false; if opStack <> nil then if opStack^.token.kind = sizeofsy then doingSizeof := true; TypeName; if doingSizeof then begin {handle a sizeof operator} op := opStack; opStack := op^.next; dispose(op); new(sp); sp^.next := stack; sp^.left := nil; sp^.middle := nil; sp^.right := nil; sp^.token.kind := longconst; sp^.token.class := longConstant; sp^.token.lval := typeSpec^.size; if typeSpec^.kind = arrayType then if (typeSpec^.elements = 0) or (typeSpec^.size = 0) then Error(49); sp^.next := stack; stack := sp; expectingTerm := false; end {if} else {doing a cast} begin {handle a type cast} new(op); {stack the cast operator} op^.left := nil; op^.middle := nil; op^.right := nil; op^.castType := typeSpec; op^.token.kind := castoper; op^.token.class := reservedWord; op^.next := opStack; opStack := op; end; {else} Match(rparench,12); end {if} else begin new(op); {record the '('} op^.next := opStack; op^.left := nil; op^.middle := nil; op^.right := nil; opStack := op; op^.token.kind := lparench; op^.token.class := reservedSymbol; parenCount := parenCount+1; end; end {else if} else begin {handle an operation...} if expectingTerm then {convert unary operators to separate tokens} if token.kind in [asteriskch,minusch,plusch,andch] then case token.kind of asteriskch: token.kind := uasterisk; minusch : token.kind := uminus; andch : token.kind := uand; plusch : begin NextToken; goto 2; end; otherwise : Error(57); end; {case} if icp[token.kind] = notAnOperation then done := true {end of expression found...} else if (token.kind in stopSym) and (parenCount = 0) then done := true else begin if not (kind in [normalExpression, autoInitializerExpression]) then if (token.kind in [plusplusop,minusminusop,eqch,pluseqop,minuseqop, opplusplus,opminusminus, asteriskeqop,slasheqop,percenteqop,ltlteqop, gtgteqop,caroteqop,bareqop,commach]) or ((kind = preprocessorExpression) and (token.kind = sizeofsy)) or ((kind <> initializerExpression) and (token.kind = uand)) then begin Error(40); errorFound := true; end; {if} if token.kind in {make sure we get what we want} [plusplusop,minusminusop,sizeofsy,tildech,excch, uasterisk,uminus,uand] then begin if not expectingTerm then begin Error(38); Skip; goto 1; end; {if} end {if} else begin if expectingTerm then begin Error(37); Skip; goto 1; end; {if} expectingTerm := true; {handle 2nd half of ternary operator} if token.kind = colonch then begin done2 := false; {do pending operations} repeat if opStack = nil then done2 := true else if opStack^.token.kind <> questionch then Operation else done2 := true; until done2; if (opStack = nil) or (opStack^.token.kind <> questionch) then begin Error(39); Skip; goto 1; end; {if} op := opStack; opStack := op^.next; dispose(op); end {if} else begin done2 := false; {do operations with less precidence} repeat if opStack = nil then done2 := true else if isp[opStack^.token.kind] >= icp[token.kind] then Operation else done2 := true; until done2; end; {else} end; {else} new(op); {record the operation} op^.next := opStack; op^.left := nil; op^.middle := nil; op^.right := nil; opStack := op; op^.token := token; NextToken; end; {else} end; {else} 2: until done; if parenCount > 0 then begin Error(12); errorFound := true; end {if} else begin while opStack <> nil do {do pending operations} Operation; {there should be exactly one operand left} if (stack = nil) or (stack^.next <> nil) then begin Error(36); errorFound := true; end; {if} end; {else} end {if} else begin {the start of an expression was not found} Error(35); if not (token.kind in stopSym) then NextToken; Skip; end; {else} 1: if errorFound then begin while opStack <> nil do begin op := opStack; opStack := op^.next; dispose(op); end; {while} while stack <> nil do begin sp := stack; stack := sp^.next; DisposeTree(sp); end; {while} ExpressionTree := nil; end {if} else ExpressionTree := stack; end; {ExpressionTree} procedure CompareToZero {op: pcodes}; { Compare the result on tos to zero. } { } { This procedure is used by the logical statements to compare } { _any_ scalar result to zero, giving a boolean result. } { } { parameters: } { op - operation to use on the compare } var bt: baseTypeEnum; {base type of loaded value} begin {CompareToZero} if expressionType^.kind = pointerType then expressionType := uLongPtr; if expressionType^.kind = scalarType then begin bt := UsualUnaryConversions; case bt of cgByte,cgUByte,cgWord,cgUWord: Gen1t(pc_ldc, 0, cgWord); cgLong,cgULong: GenLdcLong(0); cgReal,cgDouble,cgComp,cgExtended: GenLdcReal(0.0); otherwise: Error(47); end; {case} expressionType := wordPtr; Gen0t(op, bt); end {if} else Error(47); end; {CompareToZero} procedure FreeTemp{labelNum, size: integer}; { place a temporary label in the available label list } { } { parameters: } { labelNum - number of the label to free } { size - size of the variable } { } { variables: } { tempList - list of free labels } var tl: tempPtr; {work pointer} begin {FreeTemp} new(tl); tl^.next := tempList; tl^.last := nil; tl^.labelNum := labelNum; tl^.size := size; if tempList <> nil then tempList^.last := tl; tempList := tl; end; {FreeTemp} function GetTemp{size: integer): integer}; { find a temporary work variable } { } { parameters: } { size - size of the variable } { } { variables: } { tempList - list of free labels } { } { Returns the label number. } label 1; var lcodeGeneration: boolean; {local copy of codeGeneration} ln: integer; {label number} tl: tempPtr; {work pointer} begin {GetTemp} {try to find a temp from the existing list} tl := tempList; while tl <> nil do begin if tl^.size = size then begin {found an old one - use it} if tl^.last = nil then tempList := tl^.next else tl^.last^.next := tl^.next; if tl^.next <> nil then tl^.next^.last := tl^.last; GetTemp := tl^.labelNum; goto 1; end; {if} tl := tl^.next; end; {while} {none found - get a new one} ln := GetLocalLabel; GetTemp := ln; lcodeGeneration := codeGeneration; codeGeneration := true; Gen2(dc_loc, ln, size); codeGeneration := lCodeGeneration and (numErrors = 0); 1: end; {GetTemp} procedure LoadScalar (id: identPtr); { Load a scalar value. } { } { parameters: } { id - ident for value to load } var tp: baseTypeEnum; {base type} begin {LoadScalar} if id^.itype^.kind = pointerType then tp := cgULong else tp := id^.itype^.baseType; case id^.storage of stackFrame, parameter: Gen2t(pc_lod, id^.lln, 0, tp); external, global, private: Gen1tName(pc_ldo, 0, tp, id^.name); otherwise: ; end; {case} end; {LoadScalar} procedure Cast(tp: typePtr); { Cast the current expression to the stated type } { } { parameters: } { tp - type to cast to } { } { inputs: } { expressionType - type of the expression to cast } { } { outputs: } { expressionType - set to result type } var et,rt: baseTypeEnum; {work variables} begin {Cast} if (tp^.kind = scalarType) and (expressionType^.kind = scalarType) then begin rt := tp^.baseType; et := expressionType^.baseType; if rt <> et then Gen2(pc_cnv, ord(et), ord(rt)); end {if} else if (tp^.kind = enumType) and (expressionType^.kind = scalarType) then begin rt := cgWord; et := Unary(expressionType^.baseType); if rt <> et then Gen2(pc_cnv, ord(et), ord(rt)); end {if} else if (tp^.kind = scalarType) and (expressionType^.kind = enumType) then begin rt := Unary(tp^.baseType); et := cgWord; if rt <> et then Gen2(pc_cnv, ord(et), ord(rt)); end {if} else if tp^.kind = pointerType then begin case expressionType^.kind of scalarType: if expressionType^.baseType in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong] then Gen2(pc_cnv, ord(Unary(expressionType^.baseType)), ord(cgULong)) else if doDispose then Error(40); arrayType,pointerType: ; functionType,enumConst,enumType,definedType,structType,unionType: if doDispose then Error(40); otherwise: Error(57); end; {case} end {else if} else if expressionType^.kind in [pointerType,arrayType] then begin case tp^.kind of scalarType: if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord,cgLong,cgULong] then Gen2(pc_cnv, ord(cgULong), ord(Unary(tp^.baseType))) else if tp^.baseType = cgVoid then Gen0t(pc_pop, UsualUnaryConversions) else Error(40); otherwise: Error(40); end; {case} end {else if} else if expressionType^.kind in [structType,unionType] then begin if tp^.kind = scalarType then if tp^.baseType = cgVoid then Gen0t(pc_pop, UsualUnaryConversions) else Error(40) else Error(40); end {else if} else Error(40); expressionType := tp; end; {Cast} procedure DoSelection {lType: typePtr; tree: tokenPtr; var size: longint}; { Find the displacement & type for a selection operation } { } { parameters: } { lType - structure/union type } { tree - right-hand tree } { size - disp into the structure/union } { } { returned in non-local variables: } { bitDisp - displacement to bit field } { bitSize - size of bit field } { unsigned - is the bit field unsigned? } { isBitField - is the field a bit field? } { } { varaibles: } { expressionType - set to the type of the field } label 1; var ip: identPtr; {for scanning for the field} begin {DoSelection} expressionType := wordPtr; {set defaults in case there is an error} size := 0; if tree^.token.class = identifier then begin while lType^.kind = definedType do lType := lType^.dType; if lType^.kind in [structType,unionType] then begin ip := lType^.fieldList; {find a matching field} while ip <> nil do begin if ip^.name^ = tree^.token.name^ then begin if ip^.isForwardDeclared then ResolveForwardReference(ip); size := ip^.disp; {match found - record parameters} expressionType := ip^.itype; bitDisp := ip^.bitDisp; bitSize := ip^.bitSize; isBitField := (bitSize+bitDisp) <> 0; unsigned := ip^.itype^.baseType in [cgUByte,cgUWord,cgULong]; goto 1; end; {if} ip := ip^.next; end; {while} Error(81); end {if} else Error(80); end; {if} 1: end; {DoSelection} procedure L_Value(tree: tokenPtr); { Check for an l-value } { } { parameters: } { tree - expression tree to check } var kind: tokenEnum; {for efficiency} begin {L_Value} kind := tree^.token.kind; {A variable identifier is an l-value unless it is a function or } {non-parameter array } if kind = ident then begin if tree^.id^.itype^.kind = arrayType then begin if tree^.id^.storage <> parameter then if doDispose then {prevent spurious errors} Error(78); end {if} else if tree^.id^.itype^.kind in [functionType,enumConst,enumType] then if doDispose then {prevent spurious errors} Error(78); end {if} {e.field is an l-value if and only if e is an l-value} else if kind = dotch then L_Value(tree^.left) {Bypass cast operators } {following test removed to flag bug for: } { int *p; long l; } { (long) p = l; } {else if kind = castoper then L_Value(tree^.left)} {The result of an array subscript (a[i]), indirect selection, } {or the indirection operator all show up as the uasterisk } {operator at this point. All are l-values, but nothing else } {not already allowed is an l-value. } else if kind <> uasterisk then if doDispose then {prevent spurious errors} Error(78); end; {L_Value} procedure ChangePointer (op: pcodes; size: longint; tp: baseTypeEnum); { Add or subtract an integer to a pointer } { } { The stack has a pointer and an integer (integer on TOS). } { The integer is removed, multiplied by size, and either } { added to or subtracted from the pointer; the result } { replaces the pointer on the stack } { } { parameters: } { op - operation (pc_adl or pc_sbl) } { size - size of one pointer element } { tp - type of the integer operand } begin {ChangePointer} case tp of cgByte,cgUByte,cgWord,cgUWord: begin if (size = long(size).lsw) and (op = pc_adl) and smallMemoryModel and (tp in [cgUByte,cgUWord]) then begin Gen1t(pc_ldc, long(size).lsw, cgWord); Gen0(pc_umi); Gen0t(pc_ixa, cgUWord); end {if} else if smallMemoryModel and (size = long(size).lsw) then begin Gen1t(pc_ldc, long(size).lsw, cgWord); Gen0(pc_mpi); Gen2(pc_cnv, ord(tp), ord(cgLong)); Gen0(op); end {else if} else begin Gen2(pc_cnv, ord(tp), ord(cgLong)); GenLdcLong(size); Gen0(pc_mpl); Gen0(op); end; end; cgLong,cgULong: begin GenLdcLong(size); if tp = cgLong then Gen0(pc_mpl) else Gen0(pc_uml); Gen0(op); end; otherwise: Error(66); end; {case} end; {ChangePointer} procedure GenerateCode {tree: tokenPtr}; { generate code from a fully formed expression tree } { } { parameters: } { tree - top of the expression tree to generate code from } { } { variables: } { expressionType - result type of the expression } var doingScalar: boolean; {temp; for assignment operators} et: baseTypeEnum; {temp storage for a base type} i: integer; {loop variable} isString: boolean; {was the ? : a string?} lType: typePtr; {type of operands} kind: typeKind; {temp type kind} size: longint; {size of an array element} t1: integer; {temporary work space label number} tlastwasconst: boolean; {temp lastwasconst} tlastconst: longint; {temp lastconst} tp: tokenPtr; {work pointer} tType: typePtr; {temp type of operand} lbitDisp,lbitSize: integer; {for temp storage} lisBitField: boolean; function ExpressionKind (tree: tokenPtr): typeKind; { returns the type of an expression } { } { This subroutine is used to see if + and - operarions } { should do pointer addition. } { } { parameters: } { tree - top of the expression tree to check } var ldoDispose: boolean; {local copy of doDispose} lcodeGeneration: boolean; {local copy of codeGeneration} lexpressionType: typePtr; {local copy of expressionType} begin {ExpressionKind} ldoDispose := doDispose; {inhibit disposing of the tree} doDispose := false; lcodeGeneration := codeGeneration; {inhibit code generation} codeGeneration := false; lexpressionType := expressionType; {save the expression type} GenerateCode(tree); {get the type} ExpressionKind := expressionType^.kind; doDispose := ldoDispose; {resore the volitile variables} codeGeneration := lCodeGeneration and (numErrors = 0); expressionType := lexpressionType; end; {ExpressionKind} procedure LoadAddress (tree: tokenPtr); { load the address of an l-value } { } { parameters: } { tree - top of the expression tree to load the } { address of } { } { variables: } { expressionType - result type of the expression } { isBitField - this variable is set to false so that } { it can be used to see if DoSelection was called } { and located a bit field } label 1; var eType: typePtr; {work pointer} i: integer; {loop variable} size: longint; {disp in record} tname: stringPtr; {temp name pointer} begin {LoadAddress} isBitField := false; if tree^.token.kind = ident then begin {load the address of an identifier} with tree^.id^ do begin tname := name; if itype^.kind = functionType then begin if itype^.isPascal then begin tname := pointer(Malloc(length(name^)+1)); CopyString(pointer(tname), pointer(name)); for i := 1 to length(tname^) do if tname^[i] in ['a'..'z'] then tname^[i] := chr(ord(tname^[i]) & $5F); end; {if} end; {if} case storage of stackFrame: Gen2(pc_lda, lln, 0); parameter: if itype^.kind = arrayType then Gen2t(pc_lod, pln, 0, cgULong) else Gen2(pc_lda, pln, 0); external, global, private: Gen1Name(pc_lao, 0, tname); otherwise: ; end; {case} eType := pointer(Malloc(sizeof(typeRecord))); eType^.size := cgLongSize; eType^.saveDisp := 0; eType^.isConstant := false; eType^.kind := pointerType; eType^.pType := iType; expressionType := eType; end; {with} end {if} else if tree^.token.kind = uasterisk then begin {load the address of the item pointed to by the pointer} GenerateCode(tree^.left); end {else if} else if tree^.token.kind = dotch then begin {load the address of a field of a record} LoadAddress(tree^.left); eType := expressionType; if eType^.kind in [arrayType,pointerType] then begin if eType^.kind = arrayType then eType := eType^.aType else if eType^.kind = pointerType then eType := eType^.pType; DoSelection(eType, tree^.right, size); if size <> 0 then if size & $00007FFF = size then Gen1t(pc_inc, long(size).lsw, cgULong) else begin GenLdcLong(size); Gen0(pc_adl); end; {else} eType := pointer(Malloc(sizeof(typeRecord))); eType^.size := cgLongSize; eType^.saveDisp := 0; eType^.isConstant := false; eType^.kind := pointerType; eType^.pType := expressionType; expressionType := eType; end {if} else Error(79); end {else if} else if tree^.token.kind = castoper then begin {load the address of a field of a record} LoadAddress(tree^.left); expressionType := tree^.castType; if expressionType^.kind <> arrayType then begin eType := pointer(Malloc(sizeof(typeRecord))); eType^.size := cgLongSize; eType^.saveDisp := 0; eType^.isConstant := false; eType^.kind := pointerType; eType^.pType := expressionType; expressionType := eType; end; {if} end {else if} else if ExpressionKind(tree) in [arrayType,pointerType] then GenerateCode(tree) else if doDispose then {prevent spurious errors} Error(78); 1: end; {LoadAddress} procedure DoIncDec (tree: tokenPtr; pc_l, pc_g, pc_i: pcodes); { do ++ and -- } { } { parameters: } { tree - tree to generate the instruction for } { pc_l - op code for a local ++ or -- } { pc_g - op code for a global ++ or -- } { pc_i - op code for an indirect ++ or -- } label 1; var baseType: baseTypeEnum; {type of operation} lSize: longint; {number to inc or dec by} iSize: integer; {number to inc or dec by} tp: baseTypeEnum; {type of operand} procedure IncOrDec (inc: boolean); { Increment or decrement a number on TOS } { } { parameters: } { inc - increment the number? } begin {IncOrDec} case expressionType^.kind of scalarType: case tp of cgByte,cgUByte,cgWord,cgUWord: begin Gen1t(pc_ldc, 1, cgWord); if inc then Gen0(pc_adi) else Gen0(pc_sbi); end; cgLong,cgULong: begin GenLdcLong(1); if inc then Gen0(pc_adl) else Gen0(pc_sbl); end; cgReal,cgDouble,cgComp,cgExtended: begin GenLdcReal(1.0); if inc then Gen0(pc_adr) else Gen0(pc_sbr); end; otherwise: Error(57); end; {case} pointerType,arrayType: begin GenldcLong(expressionType^.pType^.size); if inc then Gen0(pc_adl) else Gen0(pc_sbl); end; otherwise: ; end; {case} end; {IncOrDec} begin {DoIncDec} L_Value(tree); with tree^.id^ do if (tree^.token.kind = ident) and ((iType^.kind in [scalarType,pointerType]) or ((iType^.kind = arrayType) and (storage = parameter))) then begin {check for ++ or -- of a constant} if iType^.isConstant then Error(93); {do an efficient ++ or -- on a named location} if iType^.kind = scalarType then begin iSize := 1; baseType := iType^.baseType; if baseType in [cgReal,cgDouble,cgComp,cgExtended] then begin {do real inc or dec} LoadScalar(tree^.id); {load the value} tp := baseType; expressionType := iType; IncOrDec(pc_l in [pc_lli,pc_lil]); {do the ++ or --} case storage of {save the result} stackFrame, parameter: Gen2t(pc_cop, lln, 0, baseType); external, global, private: Gen1tName(pc_cpo, 0, baseType, name); otherwise: ; end; {case} {correct the value for postfix ops} if pc_l in [pc_lli,pc_lld] then IncOrDec(pc_l = pc_lld); expressionType := doublePtr; goto 1; end; {if} end {if} else {if iType^.kind = pointerType then} begin lSize := iType^.pType^.size; if long(lSize).msw <> 0 then begin {handle inc/dec of >64K} LoadScalar(tree^.id); GenLdcLong(lSize); if pc_l in [pc_lli,pc_lil] then Gen0(pc_adl) else Gen0(pc_sbl); with tree^.left^.id^ do case storage of stackFrame, parameter: Gen2t(pc_cop, lln, 0, cgULong); external, global, private: Gen1tName(pc_cpo, 0, cgULong, name); otherwise: ; end; {case} if pc_l in [pc_lli,pc_lld] then begin GenLdcLong(lSize); if pc_l = pc_lld then Gen0(pc_adl) else Gen0(pc_sbl); end; {if} goto 1; end; {if} baseType := cgULong; iSize := long(lSize).lsw; end; {else} case storage of stackFrame, parameter: Gen2t(pc_l, lln, iSize, baseType); external, global, private: Gen2tName(pc_g, iSize, 0, baseType, name); otherwise: ; end; {case} expressionType := itype; end {if} else begin {do an indirect ++ or --} LoadAddress(tree); {get the address to save to} if expressionType^.kind = arrayType then expressionType := expressionType^.aType else if expressionType^.kind = pointerType then expressionType := expressionType^.pType; if expressionType^.kind = scalarType then if expressionType^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then tp := expressionType^.baseType else tp := UsualUnaryConversions else tp := UsualUnaryConversions; if tp in [cgByte,cgUByte,cgWord,cgUword] then Gen0t(pc_i, tp) {do indirect inc/dec} else begin t1 := GetTemp(cgLongSize); Gen2t(pc_str, t1, 0, cgULong); Gen2t(pc_lod, t1, 0, cgULong); Gen2t(pc_lod, t1, 0, cgULong); FreeTemp(t1, cgLongSize); Gen1t(pc_ind, 0, tp); {load the value} IncOrDec(pc_l in [pc_lli,pc_lil]); {do the ++ or --} if isBitField then {copy the value} if bitDisp+bitSize > 16 then begin Gen2t(pc_cbf, bitDisp, bitSize, cgLong); Gen0t(pc_bno, cgLong); end {if} else begin Gen2t(pc_cbf, bitDisp, bitSize, cgWord); Gen0t(pc_bno, cgWord); end {else} else begin Gen0t(pc_cpi, tp); Gen0t(pc_bno, tp); end; {else} if pc_l in [pc_lli,pc_lld] then {correct the value for postfix ops} IncOrDec(pc_l = pc_lld); end; {else} end; {else} 1: end; {DoIncDec} procedure FunctionCall (tree: tokenPtr); { generate the actual function call } var fName: stringPtr; {uppercase file name} fntype: typePtr; {temp function type} ftree: tokenPtr; {function address tree} ftype: typePtr; {function type} i: integer; {loop variable} indirect: boolean; {is this an indirect call?} ldoDispose: boolean; {local copy of doDispose} lcodeGeneration: boolean; {local copy of codeGeneration} procedure FunctionParms (parms: tokenPtr; fType: typePtr); { Generate a function call. } { } { parameters: } { parms - parameter list } { fType - function type } var kind: typeKind; {for expression kinds} ldoDispose: boolean; {local copy of doDispose} lnumErrors: integer; {number of errors before type check} numParms: integer; {# of parameters generated} parameters: parameterPtr; {next prototyped parameter} pCount: integer; {# of parameters prototyped} prototype: boolean; {is the function prototyped?} tp,ltp: tokenPtr; {work pointers} procedure Reverse; { Reverse the parameter list } var p1,p2,p3: tokenPtr; {work pointers} begin {Reverse} p3 := parms; {remove the last entry} p1 := parms; p2 := nil; while p3^.right <> nil do begin p2 := p3; p3 := p3^.right; end; {while} if p2 <> nil then p2^.right := nil else p1 := nil; while p1 <> nil do begin {reverse the remaining parms} p2 := p1; p1 := p1^.right; p2^.right := p3; p3 := p2; end; {while} parms := p3; end; {Reverse} begin {FunctionParms} {check the validity of the parameter list} if ftype^.isPascal then {reverse parms for pascal calls} Reverse; tp := parms; {set up to check types} prototype := ftype^.prototyped; parameters := ftype^.parameterList; pCount := 1; while parameters <> nil do begin {count the prototypes} pCount := pCount+1; parameters := parameters^.next; end; {while} parameters := ftype^.parameterList; if prototype then begin {check for wrong # of parms} while tp <> nil do begin {count the parms} pCount := pCount-1; tp := tp^.right; end; {while} tp := parms; if (pCount > 0) or ((pCount <> 0) and not ftype^.varargs) then Error(85); end; {if} {generate the parameters} numParms := 0; lDoDispose := doDispose; doDispose := false; while tp <> nil do begin if tp^.middle <> nil then begin lnumErrors := numErrors; kind := ExpressionKind(tp^.middle); if numErrors = lnumErrors then if kind in [structType,unionType] then begin GenerateCode(tp^.middle); if expressionType^.size & $FFFF8000 <> 0 then Error(61); Gen1t(pc_ldc, long(expressionType^.size).lsw, cgWord); Gen0(pc_psh); end {else if} else GenerateCode(tp^.middle); if prototype then begin if pCount = 0 then begin if parameters <> nil then begin AssignmentConversion(parameters^.parameterType, expressionType, lastWasConst, lastConst, true, true); end; {if} parameters := parameters^.next; end {if} else pCount := pCount+1; end; {if} Gen0t(pc_stk, UsualUnaryConversions); if numParms <> 0 then Gen0t(pc_bno, UsualUnaryConversions); numParms := numParms+1; end; {if} ltp := tp; tp := tp^.right; end; {while} doDispose := lDoDispose; if numParms = 0 then Gen0(pc_nop); if ftype^.isPascal then {restore parm order} Reverse; if doDispose then begin {dispose of leaf nodes} DisposeTree(parms^.middle); DisposeTree(parms^.right); end; {if} end; {FunctionParms} begin {FunctionCall} {find the type of the function} indirect := true; {assume an indirect call} ftree := tree^.left; {get the function tree} if ftree^.token.kind = ident then {check for direct calls} if ftree^.id^.itype^.kind = functionType then begin indirect := false; fType := ftree^.id^.itype; {get the function type} end; {if} if indirect then begin {get type for indirect call} ldoDispose := doDispose; doDispose := false; lcodeGeneration := codeGeneration; codeGeneration := false; GenerateCode(ftree); doDispose := ldoDispose; codeGeneration := lCodeGeneration and (numErrors = 0); ftype := expressionType; while ftype^.kind in [pointerType,arrayType] do ftype := ftype^.ptype; end; {if} {make sure the identifier is really a function} if ftype^.kind <> functionType then Error(114) else begin {generate function parameters} FunctionParms (tree, fType); {generate the function call} expressionType := ftype^.fType; if expressionType^.kind in [structType,unionType] then expressionType := uLongPtr; if (ftype^.toolNum = 0) and (ftype^.dispatcher = 0) then begin if indirect then begin fntype := expressionType; GenerateCode(ftree); expressionType := fntype; Gen1t(pc_cui, ord(fType^.varargs and strictVararg), UsualUnaryConversions); end {if} else begin fname := ftree^.id^.name; if ftype^.isPascal then begin fname := pointer(Malloc(length(fname^)+1)); CopyString(pointer(fname), pointer(ftree^.id^.name)); for i := 1 to length(fname^) do if fName^[i] in ['a'..'z'] then fName^[i] := chr(ord(fName^[i]) & $5F); end; {if} Gen1tName(pc_cup, ord(fType^.varargs and strictVararg), UsualUnaryConversions, fname); end; {else} end {if} else GenTool(pc_tl1, ftype^.toolNum, long(ftype^.ftype^.size).lsw, ftype^.dispatcher); expressionType := ftype^.fType; lastWasConst := false; end; {else} end; {FunctionCall} procedure CompareCompatible (var t1,t2: typePtr); { Make sure that it is legal to compare t1 to t2 } begin {CompareCompatible} if (t1^.kind = functionType) or (t2^.kind = functionType) then begin if not CompTypes(t1, t2) then Error(47); end {if} else if t1^.kind in [pointerType,arrayType] then begin if t2^.kind in [pointerType,arrayType] then begin if (t1^.ptype = voidPtr) or (t2^.ptype = voidPtr) then else if t1^.kind = t2^.kind then begin if not CompTypes(t1, t2) then Error(47); end {if} else if not CompTypes(t1^.ptype, t2^.ptype) then Error(47); t2 := ulongPtr; end {if} else if (not lastwasconst) or (lastconst <> 0) then Error(47); t1 := ulongPtr; end {if} else if expressionType^.kind in [pointerType,arrayType] then begin if (not tlastwasconst) or (tlastconst <> 0) then Error(47); t2 := ulongPtr; end; {else if} end; {CompareCompatible} begin {GenerateCode} lastwasconst := false; case tree^.token.kind of parameterOper: FunctionCall(tree); ident: begin case tree^.id^.itype^.kind of scalarType: begin LoadScalar(tree^.id); expressionType := tree^.id^.itype; end; pointerType: begin LoadScalar(tree^.id); expressionType := tree^.id^.itype; end; arrayType: begin LoadAddress(tree); expressionType := expressionType^.ptype; end; functionType: LoadAddress(tree); structType, unionType: begin LoadAddress(tree); if expressionType^.kind = pointerType then expressionType := expressionType^.ptype; end; enumConst: begin Gen1t(pc_ldc, tree^.id^.itype^.eval, cgWord); expressionType := wordPtr; end; otherwise: ; end; {case} end; intConst,uintConst: begin Gen1t(pc_ldc, tree^.token.ival, cgWord); lastwasconst := true; lastconst := tree^.token.ival; if tree^.token.kind = intConst then expressionType := wordPtr else expressionType := uwordPtr; end; {case intConst} longConst,ulongConst: begin GenLdcLong(tree^.token.lval); if tree^.token.kind = longConst then expressionType := longPtr else expressionType := ulongPtr; lastwasconst := true; lastconst := tree^.token.lval; end; {case longConst} doubleConst: begin GenLdcReal(tree^.token.rval); expressionType := doublePtr; end; {case doubleConst} stringConst: begin GenS(pc_lca, tree^.token.sval); expressionType := stringTypePtr; end; {case stringConst} eqch: begin {=} L_Value(tree^.left); with tree^.left^ do begin if token.kind = ident then kind := id^.itype^.kind else kind := definedType; if kind = arrayType then if id^.storage = parameter then kind := pointerType; if (token.kind = ident) and (kind in [scalarType,pointerType]) then begin GenerateCode(tree^.right); with tree^.left^.id^ do begin if itype^.kind in [pointerType,arrayType] then lType := uLongPtr else lType := itype; AssignmentConversion(itype, expressionType, lastWasConst, lastConst, true, true); case storage of stackFrame, parameter: Gen2t(pc_cop, lln, 0, lType^.baseType); external, global, private: Gen1tName(pc_cpo, 0, lType^.baseType, name); otherwise: ; end; {case} end; {with} end {if} else begin LoadAddress(tree^.left); lType := expressionType; lisBitField := isBitField; lbitDisp := bitDisp; lbitSize := bitSize; if lType^.kind = arrayType then lType := lType^.aType else if lType^.kind = pointerType then lType := lType^.pType; GenerateCode(tree^.right); AssignmentConversion(lType, expressionType, lastWasConst, lastConst, true, true); case lType^.kind of scalarType: if lisBitField then Gen2t(pc_cbf, lbitDisp, lbitSize, lType^.baseType) else Gen0t(pc_cpi, lType^.baseType); pointerType: Gen0t(pc_cpi, cgULong); structType,unionType: Gen2(pc_mov, long(lType^.size).msw, long(lType^.size).lsw); otherwise: Error(47); end; {case} end; {else} end; {with} end; {=} pluseqop, {+=} minuseqop, {-=} asteriskeqop, {*=} slasheqop, {/=} percenteqop, {%=} ltlteqop, {<<=} gtgteqop, {>>=} andeqop, {&=} caroteqop, {^=} bareqop: with tree^.left^ do {|=} begin L_Value(tree^.left); if (token.kind = ident) and (id^.itype^.kind in [scalarType,pointerType]) then begin doingScalar := true; LoadScalar(id); lType := id^.itype; end {if} else begin doingScalar := false; LoadAddress(tree^.left); lisBitField := isBitField; lbitDisp := bitDisp; lbitSize := bitSize; t1 := GetTemp(cgLongSize); Gen2t(pc_str, t1, 0, cgULong); Gen2t(pc_lod, t1, 0, cgULong); Gen2t(pc_lod, t1, 0, cgULong); FreeTemp(t1, cgLongSize); lType := expressionType^.pType; if isBitField then begin if unsigned then Gen2t(pc_lbu, bitDisp, bitSize, lType^.baseType) else Gen2t(pc_lbf, bitDisp, bitSize, lType^.baseType); end {if} else if lType^.kind = pointerType then Gen1t(pc_ind, 0, cgULong) else Gen1t(pc_ind, 0, lType^.baseType); end; {else} if lType^.isConstant then Error(93); GenerateCode(tree^.right); if lType^.kind <> pointerType then et := UsualBinaryConversions(lType); case tree^.token.kind of pluseqop: if lType^.kind = pointerType then begin ChangePointer(pc_adl, lType^.pType^.size, UsualUnaryConversions); expressionType := lType; end else if et in [cgWord,cgUWord] then Gen0(pc_adi) else if et in [cgLong,cgULong] then Gen0(pc_adl) else if et = cgExtended then Gen0(pc_adr) else Error(66); minuseqop: if lType^.kind = pointerType then begin ChangePointer(pc_sbl, lType^.pType^.size, UsualUnaryConversions); expressionType := lType; end else if et in [cgWord,cgUWord] then Gen0(pc_sbi) else if et in [cgLong,cgULong] then Gen0(pc_sbl) else if et = cgExtended then Gen0(pc_sbr) else Error(66); asteriskeqop: if et = cgWord then Gen0(pc_mpi) else if et = cgUWord then Gen0(pc_umi) else if et = cgLong then Gen0(pc_mpl) else if et = cgULong then Gen0(pc_uml) else if et = cgExtended then Gen0(pc_mpr) else Error(66); slasheqop: if et = cgWord then Gen0(pc_dvi) else if et = cgUWord then Gen0(pc_udi) else if et = cgLong then Gen0(pc_dvl) else if et = cgULong then Gen0(pc_udl) else if et = cgExtended then Gen0(pc_dvr) else Error(66); percenteqop: if et = cgWord then Gen0(pc_mod) else if et = cgUWord then Gen0(pc_uim) else if et = cgLong then Gen0(pc_mdl) else if et = cgULong then Gen0(pc_ulm) else Error(66); ltlteqop: if et in [cgWord,cgUWord] then Gen0(pc_shl) else if et in [cgLong,cgULong] then Gen0(pc_sll) else Error(66); gtgteqop: if et = cgWord then Gen0(pc_shr) else if et = cgUWord then Gen0(pc_usr) else if et = cgLong then Gen0(pc_slr) else if et = cgULong then Gen0(pc_vsr) else Error(66); andeqop: if et in [cgWord,cgUWord] then Gen0(pc_bnd) else if et in [cgLong,cgULong] then Gen0(pc_bal) else Error(66); caroteqop: if et in [cgWord,cgUWord] then Gen0(pc_bxr) else if et in [cgLong,cgULong] then Gen0(pc_blx) else Error(66); bareqop: if et in [cgWord,cgUWord] then Gen0(pc_bor) else if et in [cgLong,cgULong] then Gen0(pc_blr) else Error(66); otherwise: Error(57); end; {case} AssignmentConversion(lType,expressionType,false,0,true,true); if doingScalar then begin if lType^.kind = pointerType then lType := uLongPtr; case id^.storage of stackFrame, parameter: Gen2t(pc_cop, id^.lln, 0, lType^.baseType); external, global, private: Gen1tName(pc_cpo, 0, lType^.baseType, id^.name); otherwise: ; end; {case} end {if} else begin if lisBitField then Gen2t(pc_cbf, lbitDisp, lbitSize, lType^.baseType) else begin if ltype^.kind in [pointerType,arrayType] then lType := uLongPtr; Gen0t(pc_cpi, lType^.baseType); end; {else} Gen0t(pc_bno, lType^.baseType); end; {else} end; {with} commach: begin {,} GenerateCode(tree^.left); if expressionType^.baseType <> cgVoid then Gen0t(pc_pop, UsualUnaryConversions); GenerateCode(tree^.right); Gen0t(pc_bno, UsualUnaryConversions); {result type is already in expressionType} end; {case commach} barbarop: begin {||} GenerateCode(tree^.left); if expressionType^.kind = pointerType then expressionType := uLongPtr else if UsualUnaryConversions = cgExtended then begin GenLdcReal(0.0); Gen0t(pc_neq, cgExtended); expressionType := wordPtr; end; {if} lType := expressionType; GenerateCode(tree^.right); if expressionType^.kind = pointerType then expressionType := uLongPtr else if UsualUnaryConversions = cgExtended then begin GenLdcReal(0.0); Gen0t(pc_neq, cgExtended); expressionType := wordPtr; end; {if} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_ior); cgLong,cgULong: Gen0(pc_lor); otherwise: error(66); end; {case} expressionType := wordPtr; end; {case barbarop} andandop: begin {&&} GenerateCode(tree^.left); if expressionType^.kind = pointerType then expressionType := uLongPtr else if UsualUnaryConversions = cgExtended then begin GenLdcReal(0.0); Gen0t(pc_neq, cgExtended); expressionType := wordPtr; end; {if} lType := expressionType; GenerateCode(tree^.right); if expressionType^.kind = pointerType then expressionType := uLongPtr else if UsualUnaryConversions = cgExtended then begin GenLdcReal(0.0); Gen0t(pc_neq, cgExtended); expressionType := wordPtr; end; {if} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_and); cgLong,cgULong: Gen0(pc_lnd); otherwise: error(66); end; {case} expressionType := wordPtr; end; {case andandop} carotch: begin {^} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_bxr); cgLong,cgULong: Gen0(pc_blx); otherwise: error(66); end; {case} end; {case carotch} barch: begin {|} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_bor); cgLong,cgULong: Gen0(pc_blr); otherwise: error(66); end; {case} end; {case barch} andch: begin {&} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_bnd); cgLong,cgULong: Gen0(pc_bal); otherwise: error(66); end; {case} end; {case andch} ltltop: begin {<<} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_shl); cgLong,cgULong: Gen0(pc_sll); otherwise: error(66); end; {case} end; {case ltltop} gtgtop: begin {>>} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgWord: Gen0(pc_shr); cgUByte,cgUWord: Gen0(pc_usr); cgLong: Gen0(pc_slr); cgULong: Gen0(pc_vsr); otherwise: error(66); end; {case} end; {case gtgtop} plusch: begin {+} if ExpressionKind(tree^.right) in [arrayType,pointerType] then begin tree^.middle := tree^.right; tree^.right := tree^.left; tree^.left := tree^.middle; end; {if} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); if lType^.kind in [arrayType,pointerType] then begin {pointer addition} et := UsualUnaryConversions; expressionType := lType; if lType^.kind = arrayType then lType := lType^.aType else lType := lType^.pType; ChangePointer(pc_adl, lType^.size, et); end {if} else begin {scalar addition} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_adi); cgLong,cgULong: Gen0(pc_adl); cgExtended: Gen0(pc_adr); otherwise: error(66); end; {case} end; {else} end; {case plusch} minusch: begin {-} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); if lType^.kind in [pointerType,arrayType] then begin if lType^.kind = arrayType then size := lType^.aType^.size else size := lType^.pType^.size; if expressionType^.kind in [arrayType,pointerType] then begin {subtraction of two pointers} Gen0(pc_sbl); if size <> 1 then begin GenLdcLong(size); Gen0(pc_dvl); end; {if} lType := longPtr; end {if} else {subtract a scalar from a pointer} ChangePointer(pc_sbl, size, UsualUnaryConversions); expressionType := lType; end {if} else begin {scalar subtraction} case UsualBinaryConversions(lType) of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_sbi); cgLong,cgULong: Gen0(pc_sbl); cgExtended: Gen0(pc_sbr); otherwise: error(66); end; {case} end; {else} end; {case minusch} asteriskch: begin {*} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgWord: Gen0(pc_mpi); cgUByte,cgUWord: Gen0(pc_umi); cgLong: Gen0(pc_mpl); cgULong: Gen0(pc_uml); cgExtended: Gen0(pc_mpr); otherwise: error(66); end; {case} end; {case asteriskch} slashch: begin {/} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgWord: Gen0(pc_dvi); cgUByte,cgUWord: Gen0(pc_udi); cgLong: Gen0(pc_dvl); cgULong: Gen0(pc_udl); cgExtended: Gen0(pc_dvr); otherwise: error(66); end; {case} end; {case slashch} percentch: begin {%} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); case UsualBinaryConversions(lType) of cgByte,cgWord: Gen0(pc_mod); cgUByte,cgUWord: Gen0(pc_uim); cgLong: Gen0(pc_mdl); cgULong: Gen0(pc_ulm); otherwise: error(66); end; {case} end; {case percentch} eqeqop, {==} exceqop: begin {!=} GenerateCode(tree^.left); lType := expressionType; tlastwasconst := lastwasconst; tlastconst := lastconst; GenerateCode(tree^.right); CompareCompatible(ltype, expressionType); if tree^.token.kind = eqeqop then Gen0t(pc_equ, UsualBinaryConversions(lType)) else Gen0t(pc_neq, UsualBinaryConversions(lType)); expressionType := wordPtr; end; {case exceqop,eqeqop} lteqop, {<=} gteqop, {>=} ltch, {<} gtch: begin {>} GenerateCode(tree^.left); lType := expressionType; GenerateCode(tree^.right); CompareCompatible(ltype, expressionType); if tree^.token.kind = lteqop then Gen0t(pc_leq, UsualBinaryConversions(lType)) else if tree^.token.kind = gteqop then Gen0t(pc_geq, UsualBinaryConversions(lType)) else if tree^.token.kind = ltch then Gen0t(pc_les, UsualBinaryConversions(lType)) else {if tree^.token.kind = gtch then} Gen0t(pc_grt, UsualBinaryConversions(lType)); expressionType := wordPtr; end; {case lteqop,gteqop,ltch,gtch} uminus: begin {unary -} GenerateCode(tree^.left); case UsualUnaryConversions of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_ngi); cgLong,cgULong: Gen0(pc_ngl); cgExtended: Gen0(pc_ngr); otherwise: error(66); end; {case} end; {case uminus} tildech: begin {~} GenerateCode(tree^.left); case UsualUnaryConversions of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_bnt); cgLong,cgULong: Gen0(pc_bnl); otherwise: error(66); end; {case} end; {case tildech} excch: begin {!} GenerateCode(tree^.left); if expressionType^.kind = pointerType then expressionType := uLongPtr; case UsualUnaryConversions of cgByte,cgUByte,cgWord,cgUWord: Gen0(pc_not); cgLong,cgULong: begin GenLdcLong(0); Gen0t(pc_equ, cgLong); end; cgExtended: begin GenLdcReal(0.0); Gen0t(pc_equ, cgExtended); end; otherwise: error(66); end; {case} expressionType := wordPtr; end; {case excch} plusplusop: {prefix ++} DoIncDec(tree^.left, pc_lil, pc_gil, pc_iil); opplusplus: {postfix ++} DoIncDec(tree^.left, pc_lli, pc_gli, pc_ili); minusminusop: {prefix --} DoIncDec(tree^.left, pc_ldl, pc_gdl, pc_idl); opminusminus: {postfix --} DoIncDec(tree^.left, pc_lld, pc_gld, pc_ild); uand: {unary & (address operator)} LoadAddress(tree^.left); uasterisk: begin {unary * (indirection)} GenerateCode(tree^.left); lType := expressionType; if lType^.kind in [functiontype,arrayType,pointerType] then begin if lType^.kind = arrayType then lType := lType^.aType else if lType^.kind = pointerType then lType := lType^.pType; expressionType := lType; if lType^.kind = scalarType then if lType^.baseType = cgVoid then Gen1t(pc_ind, 0, cgULong) else Gen1t(pc_ind, 0, lType^.baseType) else if lType^.kind = pointerType then Gen1t(pc_ind, 0, cgULong) else if not (lType^.kind in [functionType,arrayType,structType,unionType]) then Error(79); end {if} else if not (lType^.kind in [structType,unionType]) then Error(79); end; {case uasterisk} dotch: begin {.} LoadAddress(tree^.left); lType := expressionType; if lType^.kind in [arrayType,pointerType] then begin if lType^.kind = arrayType then lType := lType^.aType else if lType^.kind = pointerType then lType := lType^.pType; DoSelection(lType, tree^.right, size); if (size & $00007FFF) <> size then begin GenLdcLong(size); Gen0(pc_adl); size := 0; end; {else} kind := expressionType^.kind; if kind = scalarType then begin et := expressionType^.baseType; if isBitField then begin GenLdcLong(size); Gen0(pc_adl); if unsigned then Gen2t(pc_lbu, bitDisp, bitSize, et) else Gen2t(pc_lbf, bitDisp, bitSize, et); end {if} else Gen1t(pc_ind, long(size).lsw, et); end {if} else if kind = pointerType then Gen1t(pc_ind, long(size).lsw, cgULong) else if kind = enumType then Gen1t(pc_ind, long(size).lsw, cgWord) else if size <> 0 then Gen1t(pc_inc, long(size).lsw, cgULong); end {if} else Error(79); end; {case dotch} colonch: begin {? :} GenerateCode(tree^.left); {evaluate the condition} CompareToZero(pc_neq); GenerateCode(tree^.middle); {evaluate true expression} lType := expressionType; tlastwasconst := lastwasconst; tlastconst := lastconst; GenerateCode(tree^.right); {evaluate false expression} isString := false; {handle string operands} if lType^.kind in [arrayType,pointerType] then if lType^.aType^.baseType = cgUByte then begin with expressionType^ do if kind in [arrayType,pointerType] then begin if aType^.baseType = cgUByte then isString := true else if (kind = pointerType) and (CompTypes(lType,expressionType)) then {it's all OK} else Error(47) end {if} else if (kind = scalarType) and lastWasConst and (lastConst = 0) then et := UsualBinaryConversions(lType) {it's all OK} else Error(47); lType := voidPtrPtr; expressionType := voidPtrPtr; end; {if} with expressionType^ do if kind in [arrayType,pointerType] then if aType^.baseType in [cgByte,cgUByte] then begin if kind = pointerType then begin if tlastwasconst and (tlastconst = 0) then {it's all OK} else if CompTypes(lType, expressionType) then {it's all OK} else Error(47); end {if} else Error(47); et := UsualBinaryConversions(lType); lType := voidPtrPtr; expressionType := voidPtrPtr; end; {if} {generate the operation} if lType^.kind in [structType, unionType, arrayType] then begin if not CompTypes(lType, expressionType) then Error(47); Gen0(pc_bno); Gen0t(pc_tri, cgULong); end {if} else begin if expressionType^.kind = pointerType then tType := expressionType else tType := lType; et := UsualBinaryConversions(lType); Gen0(pc_bno); Gen0t(pc_tri, et); end; {else} if isString then {set the type for strings} expressionType := stringTypePtr; end; {case colonch} castoper: begin {(cast)} GenerateCode(tree^.left); Cast(tree^.castType); end; {case castoper} otherwise: Error(57); end; {case} if doDispose then dispose(tree); end; {GenerateCode} procedure Expression {kind: expressionKind; stopSym: tokenSet}; { handle an expression } { } { parameters: } { kind - Kind of expression; determines what operations } { and what kind of operands are allowed. } { stopSym - Set of symbols that can mark the end of an } { expression; used to skip tokens after syntax } { errors and to block certain operations. For } { example, the comma operator is not allowed in } { an expression when evaluating a function } { parameter list. } { } { variables: } { realExpressionValue - value of a real constant } { expression } { expressionValue - value of a constant expression } { expressionType - type of the constant expression } label 1; var lcodeGeneration: boolean; {local copy of codeGeneration} ldoDispose: boolean; {local copy of doDispose} tree: tokenPtr; {expression tree} castValue: tokenPtr; {element being type cast} begin {Expression} errorFound := false; {no error so far} tree := ExpressionTree(kind, stopSym); {create the expression tree} if kind = normalExpression then begin {generate code from the expression tree} if not errorFound then begin doDispose := true; GenerateCode(tree); end; {if} end {if} else begin {record the expression for an initializer} initializerTree := tree; isConstant := false; if errorFound then begin DisposeTree(initializerTree); initializerTree := nil; end {if} else begin ldoDispose := doDispose; {find the expression type} doDispose := false; lcodeGeneration := codeGeneration; codeGeneration := false; GenerateCode(tree); doDispose := ldoDispose; codeGeneration := lCodeGeneration and (numErrors = 0); {record the expression} if tree^.token.kind = castoper then begin castValue := tree^.left; while castValue^.token.kind = castoper do castValue := castValue^.left; if castValue^.token.kind in [intconst,uintconst] then begin expressionValue := castValue^.token.ival; isConstant := true; expressionType := tree^.castType; if (castValue^.token.kind = uintconst) or (expressionType^.kind = pointerType) then expressionValue := expressionValue & $0000FFFF; goto 1; end; {if} if castValue^.token.kind in [longconst,ulongconst] then begin expressionValue := castValue^.token.lval; isConstant := true; expressionType := tree^.castType; goto 1; end; {if} end; {if} if tree^.token.kind = intconst then begin expressionValue := tree^.token.ival; expressionType := wordPtr; isConstant := true; end {else if} else if tree^.token.kind = uintconst then begin expressionValue := tree^.token.ival; expressionType := uwordPtr; isConstant := true; end {else if} else if tree^.token.kind = longconst then begin expressionValue := tree^.token.lval; expressionType := longPtr; isConstant := true; end {else if} else if tree^.token.kind = ulongconst then begin expressionValue := tree^.token.lval; expressionType := ulongPtr; isConstant := true; end {else if} else if tree^.token.kind = doubleconst then begin realExpressionValue := tree^.token.rval; expressionType := extendedPtr; isConstant := true; if kind in [arrayExpression,preprocessorExpression] then begin expressionType := wordPtr; expressionValue := 1; Error(47); end; {if} end {else if} else if tree^.token.kind = stringconst then begin expressionValue := ord4(tree^.token.sval); expressionType := stringTypePtr; isConstant := true; if kind in [arrayExpression,preprocessorExpression] then begin expressionType := wordPtr; expressionValue := 1; Error(47); end; {if} end {else if} else if kind in [arrayExpression,preprocessorExpression] then begin DisposeTree(initializerTree); expressionValue := 1; end; {else if} end; {else} end; {else} 1: end; {Expression} procedure InitExpression; { initialize the expression handler } begin {InitExpression} startTerm := [ident,intconst,uintconst,longconst,ulongconst,doubleconst, stringconst]; startExpression:= startTerm + [lparench,asteriskch,andch,plusch,minusch,excch,tildech,sizeofsy, plusplusop,minusminusop,typedef]; end; {InitExpression} end. {$append 'expression.asm'} \ No newline at end of file diff --git a/Gen.pas b/Gen.pas new file mode 100755 index 0000000..81212ca --- /dev/null +++ b/Gen.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Gen } { } { Generates native code from intermediate code instructions. } { } {---------------------------------------------------------------} unit Gen; interface {$segment 'gen'} {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC, ObjOut, Native; {---------------------------------------------------------------} function LabelToDisp (lab: integer): integer; { convert a local label number to a stack frame displacement } { } { parameters: } { lab - label number } procedure Gen (blk: blockPtr); { Generates native code for a list of blocks } { } { parameters: } { blk - first of the list of blocks } {---------------------------------------------------------------} implementation const A_X = 1; {longword locations} onStack = 2; inPointer = 4; localAddress = 8; globalLabel = 16; constant = 32; {stack frame locations} {---------------------} returnSize = 3; {size of return address} type {possible locations for 4 byte values} longType = record {desciption of current four byte value} preference: integer; {where you want the value} where: integer; {where the value is at} fixedDisp: boolean; {is the displacement a fixed value?} isLong: boolean; {is long addr required for named labs?} disp: integer; {fixed displacement/local addr} lval: longint; {value} lab: stringPtr; {global label name} end; var gLong: longType; {info about last long value} namePushed: boolean; {has a name been pushed in this proc?} skipLoad: boolean; {skip load for a pc_lli, etc?} {stack frame locations} {---------------------} bankLoc: integer; {disp in dp where bank reg is stored} dworkLoc: integer; {disp in dp of 4 byte work spage for cg} funLoc: integer; {loc of fn ret value in stack frame} localSize: integer; {local space for current proc} parameterSize: integer; {# bytes of parameters for current proc} stackLoc: integer; {disp in dp where stack reg is stored} {---------------------------------------------------------------} procedure GenTree (op: icptr); forward; procedure OperA (mop: integer; op: icptr); { Do an operation on op that has addr modes equivalent to STA } { } { parameters: } { op - node to generate the leaf for } { mop - operation } var loc: integer; {stack frame position} opcode: pcodes; {temp storage} begin {OperA} opcode := op^.opcode; case opcode of pc_ldo,pc_gil,pc_gli,pc_gdl,pc_gld: begin case mop of m_cmp_imm: mop := m_cmp_abs; m_adc_imm: mop := m_adc_abs; m_and_imm: mop := m_and_abs; m_ora_imm: mop := m_ora_abs; m_sbc_imm: mop := m_sbc_abs; m_eor_imm: mop := m_eor_abs; otherwise: Error(cge1); end; {case} if opcode = pc_gil then GenNative(m_inc_abs, absolute, op^.q, op^.lab, 0) else if opcode = pc_gdl then GenNative(m_dec_abs, absolute, op^.q, op^.lab, 0); if smallMemoryModel then GenNative(mop, absolute, op^.q, op^.lab, 0) else GenNative(mop+2, longAbs, op^.q, op^.lab, 0); if opcode in [pc_gli,pc_gld] then begin if mop in [m_sbc_dir,m_cmp_dir] then GenImplied(m_php); if opcode = pc_gli then GenNative(m_inc_abs, absolute, op^.q, op^.lab, 0) else {if opcode = pc_gld then} GenNative(m_dec_abs, absolute, op^.q, op^.lab, 0); if mop in [m_sbc_dir,m_cmp_dir] then GenImplied(m_plp); end; {else} end; {case pc_ldo,pc_gil,pc_gli,pc_gdl,pc_gld} pc_lod,pc_lli,pc_lil,pc_lld,pc_ldl: begin case mop of m_cmp_imm: mop := m_cmp_dir; m_adc_imm: mop := m_adc_dir; m_and_imm: mop := m_and_dir; m_ora_imm: mop := m_ora_dir; m_sbc_imm: mop := m_sbc_dir; m_eor_imm: mop := m_eor_dir; otherwise: Error(cge1); end; {case} loc := LabelToDisp(op^.r); if opcode = pc_lod then loc := loc + op^.q; if opcode = pc_lil then GenNative(m_inc_dir, direct, loc, nil, 0) else if opcode = pc_ldl then GenNative(m_dec_dir, direct, loc, nil, 0); GenNative(mop, direct, loc, nil, 0); if opcode in [pc_lli,pc_lld] then begin if mop in [m_sbc_dir,m_cmp_dir] then GenImplied(m_php); if opcode = pc_lli then GenNative(m_inc_dir, direct, loc, nil, 0) else {if opc = pc_lld then} GenNative(m_dec_dir, direct, loc, nil, 0); if mop in [m_sbc_dir,m_cmp_dir] then GenImplied(m_plp); end; {else} end; {case pc_lod,pc_lli,pc_lil,pc_lld,pc_ldl} pc_ldc: GenNative(mop, immediate, op^.q, nil, 0); otherwise: Error(cge1); end; {case} end; {OperA} function Complex (op: icptr): boolean; { determine if loading the intermediate code involves anything } { but one reg } { } { parameters: } { code - intermediate code to check } { } { NOTE: for one and two byte values only!!! } begin {Complex} Complex := true; if op^.opcode in [pc_ldo,pc_ldc] then Complex := false else if op^.opcode in [pc_gil,pc_gli,pc_gdl,pc_gld] then Complex := smallMemoryModel else if op^.opcode = pc_lod then if LabelToDisp(op^.r) + op^.q < 256 then Complex := false else if op^.opcode in [pc_lli,pc_lil,pc_ldl,pc_lld] then if LabelToDisp(op^.r) < 256 then Complex := false; if op^.optype in [cgByte,cgUByte] then Complex := true; end; {Complex} procedure DoOp(op_imm, op_abs, op_dir: integer; icode: icptr; disp: integer); { Do an operation. } { } { Parameters: } { op_imm,op_abs,op_dir - op codes for the various } { addressing modes } { icode - intermediate code record } { disp - disp past the location (1 or 2) } var val: integer; {value for immediate operations} lval: longint; {long value for immediate operations} begin {DoOp} if icode^.opcode = pc_ldc then begin lval := icode^.lval; if disp = 0 then val := long(lval).lsw else val := long(lval).msw; GenNative(op_imm, immediate, val, nil, 0); end {if} else if icode^.opcode in [pc_lod,pc_str] then GenNative(op_dir, direct, LabelToDisp(icode^.r) + icode^.q + disp, nil, 0) else {if icode^.opcode in [pc_ldo, pc_sro] then} GenNative(op_abs, absolute, icode^.q + disp, icode^.lab, 0); end; {DoOp} procedure GetPointer (op: icptr); { convert a tree into a usable pointer for indirect } { loads/stores } { } { parameters: } { op - pointer tree } begin {GetPointer} gLong.preference := A_X+inPointer+localAddress+globalLabel; GenTree(op); if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); gLong.where := A_X; end; {if} if gLong.where = A_X then begin GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); gLong.where := inPointer; gLong.fixedDisp := true; gLong.disp := dworkLoc; end; {else if} end; {GetPointer} procedure IncAddr (size: integer); { add a two byte constant to a four byte value - generally an } { address } { } { parameters: } { size - integer to add } var lab1: integer; {branch point} begin {IncAddr} if size <> 0 then case gLong.where of onStack: begin lab1 := GenLabel; GenImplied(m_pla); if size = 1 then begin GenImplied(m_ina); GenNative(m_bne, relative, lab1, nil, 0); end {if} else begin GenImplied(m_clc); GenNative(m_adc_imm, immediate, size, nil, 0); GenNative(m_bcc, relative, lab1, nil, 0); end; {else} GenImplied(m_plx); GenImplied(m_inx); GenImplied(m_phx); GenLab(lab1); GenImplied(m_pha); end; A_X: begin lab1 := GenLabel; if size = 1 then begin GenImplied(m_ina); GenNative(m_bne, relative, lab1, nil, 0); end {if} else begin GenImplied(m_clc); GenNative(m_adc_imm, immediate, size, nil, 0); GenNative(m_bcc, relative, lab1, nil, 0); end; {else} GenImplied(m_inx); GenLab(lab1); end; inPointer: if gLong.fixedDisp then begin gLong.fixedDisp := false; GenNative(m_ldy_imm, immediate, size, nil, 0); end {if} else if size <= 4 then begin while size <> 0 do begin GenImplied(m_iny); size := size - 1; end; {while} end {else if} else begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_imm, immediate, size, nil, 0); GenImplied(m_tay); end; {else} localAddress,globalLabel: gLong.disp := gLong.disp+size; otherwise: Error(cge1); end; {case} end; {IncAddr} procedure LoadX (op: icptr); { Load X with a two byte value } { } { parameters: } { op - value to load } var q, r: integer; lab: stringPtr; begin {LoadX} q := op^.q; r := op^.r; lab := op^.lab; case op^.opcode of pc_lao,pc_lda: Error(cge1); pc_ldc: GenNative(m_ldx_imm, immediate, q, nil, 0); pc_ldo: GenNative(m_ldx_abs, absolute, q, lab, 0); pc_gli: begin GenNative(m_ldx_abs, absolute, q, lab, 0); GenNative(m_inc_abs, absolute, q, lab, 0); end; {if} pc_gil: begin GenNative(m_inc_abs, absolute, q, lab, 0); GenNative(m_ldx_abs, absolute, q, lab, 0); end; {if} pc_gld: begin GenNative(m_ldx_abs, absolute, q, lab, 0); GenNative(m_dec_abs, absolute, q, lab, 0); end; {if} pc_gdl: begin GenNative(m_dec_abs, absolute, q, lab, 0); GenNative(m_ldx_abs, absolute, q, lab, 0); end; {if} pc_lod: GenNative(m_ldx_dir, direct, LabelToDisp(r) + q, nil, 0); pc_lli: begin GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0); GenNative(m_inc_dir, direct, LabelToDisp(r), nil, 0); end; {if} pc_lil: begin GenNative(m_inc_dir, direct, LabelToDisp(r), nil, 0); GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0); end; {if} pc_lld: begin GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0); GenNative(m_dec_dir, direct, LabelToDisp(r), nil, 0); end; {if} pc_ldl: begin GenNative(m_dec_dir, direct, LabelToDisp(r), nil, 0); GenNative(m_ldx_dir, direct, LabelToDisp(r), nil, 0); end; {if} otherwise: Error(cge1); end; {case} end; {LoadX} function NeedsCondition (opcode: pcodes): boolean; { See if the operation is one that doesn't set the condition } { code reliably } { } { Parameters: } { opcodes - operation to check } { } { Returns: True if the condition code is not set properly for } { an operand type of cgByte,cgUByte,cgWord,cgUWord, else } { false } begin {NeedsCondition} NeedsCondition := opcode in [pc_and,pc_ior,pc_cui,pc_cup,pc_lor,pc_lnd,pc_ldl,pc_lil,pc_lld, pc_lli,pc_gil,pc_gli,pc_gdl,pc_gld,pc_iil,pc_ili,pc_idl,pc_ild, pc_cop,pc_cpo,pc_cpi,pc_dvi,pc_mpi,pc_adi,pc_sbi,pc_mod,pc_bno]; end; {NeedsCondition} function SameLoc (load, save: icptr): boolean; { See if load and save represent the same location (which must } { be a direct page value or a global label). } { } { parameters: } { load - load operation } { save - save operation } { } { Returns: True the the same location is used, else false } begin {SameLoc} SameLoc := false; if save <> nil then begin if load^.opcode = pc_lod then begin if LabelToDisp(load^.r) + load^.q < 254 then if save^.opcode = pc_str then if save^.q = load^.q then if save^.r = load^.r then SameLoc := true; end {if} else if smallMemoryModel then if load^.opcode = pc_ldo then if save^.opcode = pc_sro then if load^.lab^ = save^.lab^ then if load^.q = save^.q then SameLoc := true; end; {if} end; {SameLoc} procedure SaveRetValue (optype: baseTypeEnum); { save a value returned by a function } { } { parameters: } { optype - function type } begin {SaveRetValue} if optype in [cgLong,cgULong] then begin if (A_X & gLong.preference) = 0 then begin gLong.where := onStack; GenImplied(m_phx); GenImplied(m_pha); end else gLong.where := A_X; end {if} else if optype in [cgReal,cgDouble,cgExtended,cgComp] then GenCall(8); end; {SaveRetValue} procedure GenAdlSbl (op, save: icptr); { generate code for pc_adl, pc_sbl } { } { parameters: } { op - pc_adl or pc_sbl operation } { save - save location (pc_str or pc_sro) or nil } var bcc,clc,adc_imm,inc_dir,adc_abs, {for op-code insensitive code} adc_dir,inc_abs,adc_s: integer; disp: integer; {direct page location} lab1: integer; {label number} lLong: longType; {used to reserve gLong} nd: icptr; {for swapping left/right children} opcode: pcodes; {temp storage; for efficiency} simpleStore: boolean; {is the store absolute or direct?} val: longint; {long constant value} function Simple (icode: icptr): boolean; { See if the intermediate code is simple; i.e., can be } { reached by direct page or absolute addressing. } var load: icptr; {left opcode} begin {Simple} Simple := false; if icode^.opcode = pc_ldc then Simple := true else if icode^.opcode in [pc_lod,pc_str] then begin if LabelToDisp(icode^.r) + icode^.q < 254 then Simple := true; end {else if} else if icode^.opcode in [pc_ldo,pc_sro] then Simple := smallMemoryModel; end; {Simple} begin {GenAdlSbl} {determine where the result goes} if save <> nil then gLong.preference := A_X+onStack+inPointer+localAddress+globalLabel+constant; lLong := gLong; {set up the master instructions} opcode := op^.opcode; if opcode = pc_adl then begin clc := m_clc; bcc := m_bcc; adc_imm := m_adc_imm; adc_abs := m_adc_abs; adc_dir := m_adc_dir; adc_s := m_adc_s; inc_dir := m_inc_dir; inc_abs := m_inc_abs; end {if} else begin clc := m_sec; bcc := m_bcs; adc_imm := m_sbc_imm; adc_abs := m_sbc_abs; adc_dir := m_sbc_dir; adc_s := m_sbc_s; inc_dir := m_dec_dir; inc_abs := m_dec_abs; end; {else} {if the lhs is a constant, swap the nodes} if ((op^.left^.opcode = pc_ldc) and (opcode = pc_adl)) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} {handle a constant rhs} if op^.right^.opcode = pc_ldc then val := op^.right^.lval else val := -1; if SameLoc(op^.left, save) and (long(val).msw = 0) then begin lab1 := GenLabel; if val = 1 then begin if opcode = pc_adl then begin DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0); GenNative(m_bne, relative, lab1, nil, 0); DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2); GenLab(lab1); end {if} else {if opcode = pc_sbl then} begin DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0); GenNative(m_beq, relative, lab1, nil, 0); DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0); GenLab(lab1); DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2); end; {else} end {if} else begin {rhs in [2..65535]} GenImplied(clc); DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0); GenNative(adc_imm, immediate, long(val).lsw, nil, 0); DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0); GenNative(bcc, relative, lab1, nil, 0); if opcode = pc_adl then DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2) else DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2); GenLab(lab1); end; {else} end {if constant rhs} else begin simpleStore := false; if save <> nil then simpleStore := Simple(save); if (opcode = pc_adl) and Simple(op^.left) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} if simpleStore and Simple(op^.right) then begin if Simple(op^.left) then begin GenImplied(clc); DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0); DoOp(0, m_sta_abs, m_sta_dir, save, 0); DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 2); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2); DoOp(0, m_sta_abs, m_sta_dir, save, 2); end {if} else begin gLong.preference := A_X; GenTree(op^.left); GenImplied(clc); if gLong.where = onStack then GenImplied(m_pla); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0); DoOp(0, m_sta_abs, m_sta_dir, save, 0); if gLong.where = onStack then GenImplied(m_pla) else GenImplied(m_txa); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2); DoOp(0, m_sta_abs, m_sta_dir, save, 2); end; {else} end {if} else if Simple(op^.right) then begin gLong.preference := gLong.preference & A_X; GenTree(op^.left); GenImplied(clc); if gLong.where = onStack then begin GenImplied(m_pla); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0); GenImplied(m_pha); GenNative(m_lda_s, direct, 3, nil, 0); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2); GenNative(m_sta_s, direct, 3, nil, 0); end {if} else begin DoOp(adc_imm, adc_abs, adc_dir, op^.right, 0); GenImplied(m_tay); GenImplied(m_txa); DoOp(adc_imm, adc_abs, adc_dir, op^.right, 2); GenImplied(m_tax); GenImplied(m_tya); end; {else} end {else if} else begin {doing it the hard way} gLong.preference := onStack; GenTree(op^.right); gLong.preference := onStack; GenTree(op^.left); GenImplied(clc); GenImplied(m_pla); GenNative(adc_s, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); GenImplied(m_pla); GenNative(adc_s, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); if save = nil then gLong.where := onStack else if save^.opcode = pc_str then begin disp := LabelToDisp(save^.r) + save^.q; if disp < 254 then begin GenImplied(m_pla); GenNative(m_sta_dir, direct, disp, nil, 0); GenImplied(m_pla); GenNative(m_sta_dir, direct, disp+2, nil, 0); end {else if} else begin GenNative(m_ldx_imm, immediate, disp, nil, 0); GenImplied(m_pla); GenNative(m_sta_dirX, direct, 0, nil, 0); GenImplied(m_pla); GenNative(m_sta_dirX, direct, 2, nil, 0); end; {else} end {else if} else {if save^.opcode = pc_sro then} begin GenImplied(m_pla); if smallMemoryModel then GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0) else GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0); GenImplied(m_pla); if smallMemoryModel then GenNative(m_sta_abs, absolute, save^.q+2, save^.lab, 0) else GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0); end; {else} end; {else} end; {else} end; {GenAdlSbl} procedure GenCmp (op: icptr; rOpcode: pcodes; lb: integer); { generate code for pc_les, pc_leq, pc_grt or pc_geq } { } { parameters: } { op - operation } { rOpcode - Opcode that will use the result of the } { compare. If the result is used by a tjp or fjp, } { this procedure generated special code and does the } { branch internally. } { lb - For fjp, tjp, this is the label to branch to if } { the condition is satisfied. } var i: integer; {loop variable} lab1,lab2,lab3,lab4: integer; {label numbers} num: integer; {constant to compare to} procedure Switch; { switch the operands } var nd: icptr; {used to switch nodes} begin {Switch} nd := op^.left; op^.left := op^.right; op^.right := nd; end; {Switch} begin {GenCmp} {To reduct the number of possibilities that must be handled, pc_les } {and pc_leq compares are reduced to their equivalent pc_grt and } {pc_geq instructions. } if op^.opcode = pc_les then begin Switch; op^.opcode := pc_grt; end {if} else if op^.opcode = pc_leq then begin Switch; op^.opcode := pc_geq; end; {else if} {To take advantage of shortcuts, switch operands if generating } {for a tjp or fjp with a constant left operand. } if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then if op^.left^.opcode = pc_ldc then if rOpcode in [pc_tjp,pc_fjp] then begin if op^.opcode = pc_geq then op^.opcode := pc_grt else op^.opcode := pc_geq; if rOpcode = pc_tjp then rOpcode := pc_fjp else rOpcode := pc_tjp; Switch; end; {if} {Short cuts are available for single-word operands where the } {right operand is a constant. } if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and (op^.right^.opcode = pc_ldc) then begin GenTree(op^.left); num := op^.right^.q; lab1 := GenLabel; if rOpcode = pc_fjp then begin if op^.optype in [cgByte,cgWord] then begin if NeedsCondition(op^.left^.opcode) then GenImplied(m_tax); if (num >= 0) and (num < 4) then begin if op^.opcode = pc_geq then begin if num <> 0 then begin lab2 := GenLabel; GenNative(m_bmi, relative, lab2, nil, 0); for i := 1 to num do GenImplied(m_dea); end; {if} GenNative(m_bpl, relative, lab1, nil, 0); if num <> 0 then GenLab(lab2); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else {if opcode = pc_grt then} begin lab2 := GenLabel; GenNative(m_bmi, relative, lab2, nil, 0); for i := 0 to num do GenImplied(m_dea); GenNative(m_bpl, relative, lab1, nil, 0); GenLab(lab2); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end; {else if} end {if (num >= 0) and (num < 4)} else begin lab2 := GenLabel; if num > 0 then GenNative(m_bmi, relative, lab1, nil, 0) else GenNative(m_bpl, relative, lab1, nil, 0); GenNative(m_cmp_imm, immediate, num, nil, 0); if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); GenNative(m_bcs, relative, lab2, nil, 0); GenLab(lab3); end else GenNative(m_bcs, relative, lab2, nil, 0); if num > 0 then begin GenLab(lab1); GenNative(m_brl, longrelative, lb, nil, 0); end {if} else begin GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end; {else} GenLab(lab2); end; {else if} end {if} else {if optype in [cgUByte,cgUWord] then} begin GenNative(m_cmp_imm, immediate, num, nil, 0); if op^.opcode = pc_grt then begin lab2 := GenLabel; GenNative(m_beq, relative, lab2, nil, 0); end; {if} GenNative(m_bcs, relative, lab1, nil, 0); if op^.opcode = pc_grt then GenLab(lab2); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end; {else} end {if rOpcode = pc_fjp} else if rOpcode = pc_tjp then begin if op^.optype in [cgByte,cgWord] then begin if NeedsCondition(op^.left^.opcode) then GenImplied(m_tax); if (num >= 0) and (num < 4) then begin lab2 := GenLabel; if op^.opcode = pc_geq then begin GenNative(m_bmi, relative, lab1, nil, 0); if num > 0 then begin for i := 1 to num do GenImplied(m_dea); GenNative(m_bmi, relative, lab2, nil, 0); end; {if} GenNative(m_brl, longrelative, lb, nil, 0); end {if} else {if op^.opcode = pc_grt then} begin if num > 0 then begin GenNative(m_bmi, relative, lab1, nil, 0); for i := 0 to num do GenImplied(m_dea); GenNative(m_bmi, relative, lab2, nil, 0); end {if} else begin GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_bmi, relative, lab2, nil, 0); end; {else} GenNative(m_brl, longrelative, lb, nil, 0); end; {else} GenLab(lab2); GenLab(lab1); end {if (num >= 0) and (num < 4)} else begin lab2 := GenLabel; if num > 0 then GenNative(m_bmi, relative, lab1, nil, 0) else GenNative(m_bpl, relative, lab1, nil, 0); GenNative(m_cmp_imm, immediate, num, nil, 0); if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); end; {if} GenNative(m_bcc, relative, lab2, nil, 0); if num > 0 then begin GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab2); GenLab(lab1); end {if} else begin GenLab(lab1); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab2); end; {else} if op^.opcode = pc_grt then GenLab(lab3); end; {else} end {if} else {if optype in [cgUByte,cgUWord] then} begin GenNative(m_cmp_imm, immediate, num, nil, 0); GenNative(m_bcc, relative, lab1, nil, 0); if op^.opcode = pc_grt then begin lab2 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); end; {if} GenNative(m_brl, longrelative, lb, nil, 0); if op^.opcode = pc_grt then GenLab(lab2); GenLab(lab1); end; {else} end {if rOpcode = pc_tjp} else if op^.optype in [cgByte,cgWord] then begin lab2 := GenLabel; GenNative(m_ldx_imm, immediate, 1, nil, 0); GenImplied(m_sec); GenNative(m_sbc_imm, immediate, num, nil, 0); if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); end; {if} GenNative(m_bvs, relative, lab1, nil, 0); GenNative(m_eor_imm, immediate, $8000, nil, 0); GenLab(lab1); GenNative(m_bmi, relative, lab2, nil, 0); if op^.opcode = pc_grt then GenLab(lab3); GenImplied(m_dex); GenLab(lab2); GenImplied(m_txa); end {else if} else begin GenNative(m_ldx_imm, immediate, 0, nil, 0); GenNative(m_cmp_imm, immediate, num, nil, 0); GenNative(m_bcc, relative, lab1, nil, 0); if op^.opcode = pc_grt then GenNative(m_beq, relative, lab1, nil, 0); GenImplied(m_inx); GenLab(lab1); GenImplied(m_txa); end; {else if} end {if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and (op^.right^.opcode = pc_ldc)} {This section of code handles the cases where the above short } {cuts cannot be used. } else case op^.optype of cgByte,cgUByte,cgWord,cgUWord: begin if Complex(op^.right) then begin GenTree(op^.right); if Complex(op^.left) then begin GenImplied(m_pha); GenTree(op^.left); GenImplied(m_ply); GenNative(m_sty_dir, direct, dworkLoc, nil, 0); end {if} else begin GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenTree(op^.left); end; {else} if not (rOpcode in [pc_fjp,pc_tjp]) then GenNative(m_ldx_imm, immediate, 1, nil, 0); if op^.optype in [cgByte,cgWord] then begin GenImplied(m_sec); GenNative(m_sbc_dir, direct, dworkLoc, nil, 0); end {if} else GenNative(m_cmp_dir, direct, dworkLoc, nil, 0); end {if} else begin GenTree(op^.left); if not (rOpcode in [pc_fjp,pc_tjp]) then GenNative(m_ldx_imm, immediate, 1, nil, 0); if op^.optype in [cgByte,cgWord] then begin GenImplied(m_sec); OperA(m_sbc_imm, op^.right); if op^.right^.opcode in [pc_lld,pc_lli,pc_gli,pc_gld] then GenImplied(m_tay); end {if} else OperA(m_cmp_imm, op^.right); end; {else} if rOpcode = pc_fjp then begin lab2 := GenLabel; if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); end; {if} if op^.optype in [cgByte,cgWord] then begin lab1 := GenLabel; GenNative(m_bvs, relative, lab1, nil, 0); GenNative(m_eor_imm, immediate, $8000, nil, 0); GenLab(lab1); GenNative(m_bmi, relative, lab2, nil, 0); end {if} else GenNative(m_bcs, relative, lab2, nil, 0); if op^.opcode = pc_grt then GenLab(lab3); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab2); end {if} else if rOpcode = pc_tjp then begin lab2 := GenLabel; if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); end; {if} if op^.optype in [cgByte,cgWord] then begin lab1 := GenLabel; GenNative(m_bvs, relative, lab1, nil, 0); GenNative(m_eor_imm, immediate, $8000, nil, 0); GenLab(lab1); GenNative(m_bpl, relative, lab2, nil, 0); end {if} else GenNative(m_bcc, relative, lab2, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); if op^.opcode = pc_grt then GenLab(lab3); GenLab(lab2); end {else if} else begin lab2 := GenLabel; if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); end; {if} if op^.optype in [cgByte,cgWord] then begin lab1 := GenLabel; GenNative(m_bvs, relative, lab1, nil, 0); GenNative(m_eor_imm, immediate, $8000, nil, 0); GenLab(lab1); GenNative(m_bmi, relative, lab2, nil, 0); end {if} else GenNative(m_bcs, relative, lab2, nil, 0); if op^.opcode = pc_grt then GenLab(lab3); GenImplied(m_dex); GenLab(lab2); GenImplied(m_txa); end; {else} end; {case optype of cgByte,cgUByte,cgWord,cgUWord} cgULong: begin gLong.preference := onStack; GenTree(op^.right); gLong.preference := A_X; GenTree(op^.left); if gLong.where = onStack then begin GenImplied(m_ply); GenImplied(m_pla); end {if} else begin GenImplied(m_tay); GenImplied(m_txa); end; {else} lab1 := GenLabel; GenNative(m_ldx_imm, immediate, 1, nil, 0); GenNative(m_cmp_s, direct, 3, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); GenImplied(m_tya); GenNative(m_cmp_s, direct, 1, nil, 0); GenLab(lab1); lab2 := GenLabel; if op^.opcode = pc_grt then begin lab3 := GenLabel; GenNative(m_beq, relative, lab3, nil, 0); end; {if} GenNative(m_bcs, relative, lab2, nil, 0); if op^.opcode = pc_grt then GenLab(lab3); GenImplied(m_dex); GenLab(lab2); GenImplied(m_pla); GenImplied(m_pla); GenImplied(m_txa); if rOpcode = pc_fjp then begin lab4 := GenLabel; GenNative(m_bne, relative, lab4, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab4); end {if} else if rOpcode = pc_tjp then begin lab4 := GenLabel; GenNative(m_beq, relative, lab4, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab4); end; {else if} end; cgReal,cgDouble,cgComp,cgExtended: begin GenTree(op^.left); GenTree(op^.right); num := 31; if op^.opcode = pc_geq then GenCall(32) else GenCall(31); if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin lab1 := GenLabel; if rOpcode = pc_fjp then GenNative(m_bne, relative, lab1, nil, 0) else GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_brl,longrelative,lb,nil,0); GenLab(lab1); end; {if} end; {case optype of cgReal..cgExtended} cgLong: begin gLong.preference := onStack; GenTree(op^.left); if op^.opcode = pc_geq then begin gLong.preference := A_X; GenTree(op^.right); if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); end; {if} num := 30; end {if} else begin gLong.preference := onStack; GenTree(op^.right); num := 29; end; {else} GenCall(num); if (rOpcode = pc_fjp) or (rOpcode = pc_tjp) then begin lab1 := GenLabel; if rOpcode = pc_fjp then GenNative(m_bne, relative, lab1, nil, 0) else GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end; {if} end; {case optype of cgLong} otherwise: Error(cge1); end; {case} end; {GenCmp} procedure GenCnv (op: icptr); { generate a pc_cnv instruction } const {note: these constants list all legal } { conversions; others are ignored} cReal = $06; cDouble = $07; cComp = $08; cExtended = $09; cVoid = $0B; byteToWord = $02; byteToUword = $03; byteToLong = $04; byteToUlong = $05; byteToReal = $06; byteToDouble = $07; ubyteToLong = $14; ubyteToUlong = $15; ubyteToReal = $16; ubyteToDouble = $17; wordToByte = $20; wordToUByte = $21; wordToLong = $24; wordToUlong = $25; wordToReal = $26; wordToDouble = $27; uwordToByte = $30; uwordToUByte = $31; uwordToLong = $34; uwordToUlong = $35; uwordToReal = $36; uwordToDouble = $37; longTobyte = $40; longToUbyte = $41; longToWord = $42; longToUword = $43; longToReal = $46; longToDouble = $47; longToVoid = $4B; ulongTobyte = $50; ulongToUbyte = $51; ulongToWord = $52; ulongToUword = $53; ulongToReal = $56; ulongToDouble = $57; ulongToVoid = $5B; realTobyte = $60; realToUbyte = $61; realToWord = $62; realToUword = $63; realToLong = $64; realToUlong = $65; realToVoid = $6B; doubleTobyte = $70; doubleToUbyte = $71; doubleToWord = $72; doubleToUword = $73; doubleToLong = $74; doubleToUlong = $75; var fromReal: boolean; {are we converting from a real?} lab1: integer; {used for branches} lLong: longType; {used to reserve gLong} begin {GenCnv} lLong := gLong; gLong.preference := onStack+A_X+constant; gLong.where := onStack; if ((op^.q & $00F0) >> 4) in [cDouble,cExtended,cComp] then begin op^.q := (op^.q & $000F) | (cReal * 16); fromReal := true; end {if} else fromReal := false; if (op^.q & $000F) in [cDouble,cExtended,cComp] then op^.q := (op^.q & $00F0) | cReal; GenTree(op^.left); if op^.q in [wordToLong,wordToUlong] then begin lab1 := GenLabel; GenNative(m_ldx_imm, immediate, 0, nil, 0); GenImplied(m_tay); GenNative(m_bpl, relative, lab1, nil, 0); GenImplied(m_dex); GenLab(lab1); if (lLong.preference & A_X) <> 0 then gLong.where := A_X else begin gLong.where := onStack; GenImplied(m_phx); GenImplied(m_pha); end; {else} end {if} else if op^.q in [byteToLong,byteToUlong] then begin lab1 := GenLabel; GenNative(m_ldx_imm, immediate, 0, nil, 0); GenNative(m_bit_imm, immediate, $0080, nil, 0); GenNative(m_beq, relative, lab1, nil, 0); GenImplied(m_dex); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); if (lLong.preference & A_X) <> 0 then gLong.where := A_X else begin gLong.where := onStack; GenImplied(m_phx); GenImplied(m_pha); end; {else} end {if} else if op^.q in [byteToWord,byteToUword] then begin lab1 := GenLabel; GenNative(m_bit_imm, immediate, $0080, nil, 0); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); end {if} else if op^.q in [ubyteToLong,ubyteToUlong,uwordToLong,uwordToUlong] then begin if (lLong.preference & A_X) <> 0 then begin gLong.where := A_X; GenNative(m_ldx_imm, immediate, 0, nil, 0); end {if} else begin gLong.where := onStack; GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_pha); end; {else} end {else if} else if op^.q in [wordToByte,wordToUbyte,uwordToByte,uwordToUbyte] then GenNative(m_and_imm, immediate, $00FF, nil, 0) else if op^.q in [byteToReal,uByteToReal,wordToReal] then GenCall(11) else if op^.q = uwordToReal then begin GenNative(m_ldx_imm, immediate, 0, nil, 0); GenCall(12); end {else if} else if op^.q in [longToByte,longToUbyte,ulongToByte,ulongToUbyte] then begin if gLong.where = A_X then GenNative(m_and_imm, immediate, $00FF, nil, 0) else if gLong.where = constant then GenNative(m_lda_imm, immediate, long(gLong.lval).lsw & $00FF, nil, 0) else {if gLong.where = onStack then} begin GenImplied(m_pla); GenImplied(m_plx); GenNative(m_and_imm, immediate, $00FF, nil, 0); end; {else if} end {else if} else if op^.q in [longToWord,longToUword,ulongToWord,ulongToUword] then begin {Note: if the result is in A_X, no further action is needed} if gLong.where = constant then GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0) else if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); end; {else if} end {else if} else if op^.q in [longToReal,uLongToReal] then begin if gLong.where = constant then begin GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0); GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0); end {if} else if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); end; {else if} if op^.q = longToReal then GenCall(12) else GenCall(13); end {else} else if op^.q in [realToByte,realToUbyte,realToWord] then begin GenCall(14); if (op^.q & $00FF) in [0,1] then GenNative(m_and_imm, immediate, $00FF, nil, 0); end {else if} else if op^.q = realToUword then GenCall(15) else if op^.q in [realToLong,realToUlong] then begin if op^.q & $00FF = 5 then GenCall(17) else GenCall(16); if (lLong.preference & A_X) <> 0 then gLong.where := A_X else begin gLong.where := onStack; GenImplied(m_phx); GenImplied(m_pha); end; {else} end {else if} else if op^.q = realToVoid then begin GenImplied(m_tsc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, 10, nil, 0); GenImplied(m_tcs); end {else if} else if op^.q in [longToVoid,ulongToVoid] then begin if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); gLong.where := A_X; end; {if} end {else if} else if (op^.q & $000F) = cVoid then {do nothing} else if lLong.preference & gLong.where = 0 then begin if gLong.where = constant then begin GenNative(m_pea, immediate, long(gLong.lval).msw, nil, 0); GenNative(m_pea, immediate, long(gLong.lval).lsw, nil, 0); end {if} else if gLong.where = A_X then begin GenImplied(m_phx); GenImplied(m_pha); end; {else if} gLong.where := onStack; end; {else if} end; {GenCnv} procedure GenEquNeq (op: icptr; opcode: pcodes; lb: integer); { generate a pc_equ or pc_neq instruction } { } { parameters: } { op - node to generate the compare for } { opcode - Opcode that will use the result of the compare. } { If the result is used by a tjp or fjp, this procedure } { generates special code and does the branch internally. } { lb - For fjp, tjp, this is the label to branch to if } { the condition is satisfied. } var nd: icptr; {work node} num: integer; {constant to compare to} lab1,lab2: integer; {label numbers} bne: integer; {instruction for a pc_equ bne branch} beq: integer; {instruction for a pc_equ beq branch} lLong: longType; {local long value information} leftOp,rightOp: pcodes; {opcode codes to left, right} procedure DoOr (op: icptr); { or the two halves of a four byte value } { } { parameters: } { operand to or } var disp: integer; {disp of value on stack frame} begin {DoOr} with op^ do begin if opcode = pc_ldo then begin GenNative(m_lda_abs, absolute, q, lab, 0); GenNative(m_ora_abs, absolute, q+2, lab, 0); end {if} else begin disp := LabelToDisp(r) + q; if disp < 254 then begin GenNative(m_lda_dir, direct, disp, nil, 0); GenNative(m_ora_dir, direct, disp+2, nil, 0); end {else if} else begin GenNative(m_ldx_imm, immediate, disp, nil, 0); GenNative(m_lda_dirX, direct, 0, nil, 0); GenNative(m_ora_dirX, direct, 2, nil, 0); end; {else} end; {else} end; {with} end; {DoOr} procedure DoCmp (op: icPtr); { compare a long value in A_X to a local or global scalar } { } { parameters: } { op - value to compare to } var disp: integer; {disp of value on stack frame} lab1: integer; {label numbers} begin {DoCmp} lab1 := GenLabel; with op^ do begin if opcode = pc_ldo then begin GenNative(m_cmp_abs, absolute, q, lab, 0); GenNative(m_bne, relative, lab1, nil, 0); GenNative(m_cpx_abs, absolute, q+2, lab, 0); end {if} else begin disp := LabelToDisp(r) + q; if disp < 254 then begin GenNative(m_cmp_dir, direct, disp, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); GenNative(m_cpx_dir, direct, disp+2, nil, 0); end {if} else begin GenImplied(m_txy); GenNative(m_ldx_imm, immediate, disp, nil, 0); GenNative(m_cmp_dirX, direct, 0, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); GenImplied(m_tya); GenNative(m_cmp_dirX, direct, 2, nil, 0); end; {else} end; {else} GenLab(lab1); end; {with} end; {DoCmp} begin {GenEquNeq} if op^.opcode = pc_equ then begin bne := m_bne; beq := m_beq; end {if} else begin bne := m_beq; beq := m_bne; end; {else} if op^.left^.opcode in [pc_lod,pc_ldo] then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} if op^.left^.opcode = pc_ldc then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} leftOp := op^.left^.opcode; {set op codes for fast access} rightOp := op^.right^.opcode; if (op^.optype in [cgByte,cgUByte,cgWord,cgUWord]) and (rightOp = pc_ldc) then begin GenTree(op^.left); num := op^.right^.q; lab1 := GenLabel; if opcode in [pc_fjp,pc_tjp] then begin if num <> 0 then GenNative(m_cmp_imm, immediate, num, nil, 0) else if NeedsCondition(leftOp) then GenImplied(m_tay); if opcode = pc_fjp then GenNative(beq, relative, lab1, nil, 0) else GenNative(bne, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else begin GenNative(m_ldx_imm, immediate, 0, nil, 0); GenNative(m_cmp_imm, immediate, num, nil, 0); GenNative(bne, relative, lab1, nil, 0); GenImplied(m_inx); GenLab(lab1); GenImplied(m_txa); end; {else} end {if} else if (op^.optype in [cgLong,cgULong]) and (leftOp in [pc_ldo,pc_lod]) and (rightOp = pc_ldc) and (op^.right^.lval = 0) then begin if opcode in [pc_fjp,pc_tjp] then begin DoOr(op^.left); lab1 := GenLabel; if opcode = pc_fjp then GenNative(beq, relative, lab1, nil, 0) else GenNative(bne, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else if op^.opcode = pc_equ then begin lab1 := GenLabel; lab2 := GenLabel; DoOr(op^.left); GenNative(bne, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenNative(m_bra, relative, lab2, nil, 0); GenLab(lab1); GenNative(m_lda_imm, immediate, 0, nil, 0); GenLab(lab2); end {else if} else {if op^.opcode = pc_neq then} begin lab1 := GenLabel; DoOr(op^.left); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenLab(lab1); end; {else if} end {else if} else if (op^.optype in [cgLong,cgULong]) and (rightOp in [pc_ldo,pc_lod]) then begin gLong.preference := A_X; GenTree(op^.left); if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); end; {if} if opcode in [pc_fjp,pc_tjp] then begin DoCmp(op^.right); lab1 := GenLabel; if opcode = pc_fjp then GenNative(beq, relative, lab1, nil, 0) else GenNative(bne, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else begin lab1 := GenLabel; lab2 := GenLabel; DoCmp(op^.right); GenNative(bne, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenNative(m_bra, relative, lab2, nil, 0); GenLab(lab1); GenNative(m_lda_imm, immediate, 0, nil, 0); GenLab(lab2); end; {else} end {else if} else case op^.optype of cgByte,cgUByte,cgWord,cgUWord: begin if not Complex(op^.left) then if Complex(op^.right) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} GenTree(op^.left); if Complex(op^.right) or (not (opcode in [pc_fjp,pc_tjp])) then begin GenImplied(m_pha); GenTree(op^.right); GenImplied(m_sec); GenNative(m_sbc_s, direct, 1, nil, 0); GenImplied(m_plx); GenImplied(m_tax); if opcode in [pc_fjp,pc_tjp] then begin lab1 := GenLabel; if opcode = pc_fjp then GenNative(beq, relative, lab1, nil, 0) else GenNative(bne, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else begin lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenLab(lab1); if op^.opcode = pc_equ then GenNative(m_eor_imm, immediate, 1, nil, 0); end; {else} end {if} else begin OperA(m_cmp_imm, op^.right); lab1 := GenLabel; if opcode = pc_fjp then GenNative(beq, relative, lab1, nil, 0) else GenNative(bne, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end; {else} end; {case optype of cgByte,cgUByte,cgWord,cgUWord} cgLong,cgULong: begin gLong.preference := onStack; GenTree(op^.left); lLong := gLong; gLong.preference := A_X; GenTree(op^.right); if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); end; {if} GenNative(m_ldy_imm, immediate, 1, nil, 0); GenNative(m_cmp_s, direct, 1, nil, 0); lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenImplied(m_dey); GenLab(lab1); GenImplied(m_txa); GenNative(m_cmp_s, direct, 3, nil, 0); lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ldy_imm, immediate, 0, nil, 0); GenLab(lab1); GenImplied(m_pla); GenImplied(m_pla); GenImplied(m_tya); if opcode in [pc_fjp,pc_tjp] then begin lab1 := GenLabel; if opcode = pc_fjp then GenNative(bne, relative, lab1, nil, 0) else GenNative(beq, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else if op^.opcode = pc_neq then GenNative(m_eor_imm, immediate, 1, nil, 0); end; {case optype of cgLong,cgULong} cgReal,cgDouble,cgComp,cgExtended: begin GenTree(op^.left); GenTree(op^.right); GenCall(36); if opcode in [pc_fjp,pc_tjp] then begin lab1 := GenLabel; if opcode = pc_fjp then GenNative(bne, relative, lab1, nil, 0) else GenNative(beq, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lb, nil, 0); GenLab(lab1); end {if} else if op^.opcode = pc_neq then GenNative(m_eor_imm, immediate, 1, nil, 0); end; {case optype of cgReal..cgExtended,cgSet,cgString} otherwise: Error(cge1); end; {case} end; {GenEquNeq} procedure GenGilGliGdlGld (op: icptr); { Generate code for a pc_gil, pc_gli, pc_gdl or pc_gld } var lab1: integer; {branch point} lab: stringPtr; {op^.lab} opcode: pcodes; {op^.opcode} q: integer; {op^.q} procedure DoGIncDec (opcode: pcodes; lab: stringPtr; p, q: integer); { Do a decrement or increment on a global four byte value } { } { parameters } { opcode - operation code } { lab - label } { q - disp to value } { p - number to ind/dec by } var lab1: integer; {branch point} begin {DoGIncDec} if smallMemoryModel then begin if opcode in [pc_gil,pc_gli] then begin lab1 := GenLabel; if p = 1 then begin GenNative(m_inc_abs, absolute, q, lab, 0); GenNative(m_bne, relative, lab1, nil, 0); end {if} else begin GenImplied(m_clc); GenNative(m_lda_abs, absolute, q, lab, 0); GenNative(m_adc_imm, immediate, p, nil, 0); GenNative(m_sta_abs, absolute, q, lab, 0); GenNative(m_bcc, relative, lab1, nil, 0); end; {else} GenNative(m_inc_abs, absolute, q+2, lab, 0); GenLab(lab1); end {if} else {if opcode in [pc_gdl,pc_gld] then} begin lab1 := GenLabel; if p = 1 then begin GenNative(m_lda_abs, absolute, q, lab, 0); GenNative(m_bne, relative, lab1, nil, 0); GenNative(m_dec_abs, absolute, q+2, lab, 0); GenLab(lab1); GenNative(m_dec_abs, absolute, q, lab, 0); end {if} else begin GenImplied(m_sec); GenNative(m_lda_abs, absolute, q, lab, 0); GenNative(m_sbc_imm, immediate, p, nil, 0); GenNative(m_sta_abs, absolute, q, lab, 0); GenNative(m_bcs, relative, lab1, nil, 0); GenNative(m_dec_abs, absolute, q+2, lab, 0); GenLab(lab1); end; {else} end {else} end {of smallMemoryModel} else begin if opcode in [pc_gil,pc_gli] then begin lab1 := GenLabel; GenImplied(m_clc); GenNative(m_lda_long, longabsolute, q, lab, 0); GenNative(m_adc_imm, immediate, p, nil, 0); GenNative(m_sta_long, longabsolute, q, lab, 0); GenNative(m_bcc, relative, lab1, nil, 0); GenNative(m_lda_long, longabsolute, q+2, lab, 0); GenImplied(m_ina); GenNative(m_sta_long, longabsolute, q+2, lab, 0); GenLab(lab1); end {if} else {if opcode in [pc_gdl,pc_gld] then} begin lab1 := GenLabel; GenImplied(m_sec); GenNative(m_lda_long, longabsolute, q, lab, 0); GenNative(m_sbc_imm, immediate, p, nil, 0); GenNative(m_sta_long, longabsolute, q, lab, 0); GenNative(m_bcs, relative, lab1, nil, 0); GenNative(m_lda_long, longabsolute, q+2, lab, 0); GenImplied(m_dea); GenNative(m_sta_long, longabsolute, q+2, lab, 0); GenLab(lab1); end; {else if} end; {else} end; {DoGIncDec} begin {GenGilGliGdlGld} opcode := op^.opcode; q := op^.q; lab := op^.lab; case op^.optype of cgWord, cgUWord: begin if opcode = pc_gil then GenNative(m_inc_abs, absolute, q, lab, 0) else if opcode = pc_gdl then GenNative(m_dec_abs, absolute, q, lab, 0); if not skipLoad then GenNative(m_lda_abs, absolute, q, lab, 0); if opcode = pc_gli then GenNative(m_inc_abs, absolute, q, lab, 0) else if opcode = pc_gld then GenNative(m_dec_abs, absolute, q, lab, 0); end; cgByte, cgUByte: begin GenNative(m_sep, immediate, 32, nil, 0); if opcode = pc_gil then GenNative(m_inc_abs, absolute, q, lab, 0) else if opcode = pc_gdl then GenNative(m_dec_abs, absolute, q, lab, 0); if not skipLoad then GenNative(m_lda_abs, absolute, q, lab, 0); if opcode = pc_gli then GenNative(m_inc_abs, absolute, q, lab, 0) else if opcode = pc_gld then GenNative(m_dec_abs, absolute, q, lab, 0); GenNative(m_rep, immediate, 32, nil, 0); if not skipLoad then begin GenNative(m_and_imm, immediate, 255, nil, 0); if op^.optype = cgByte then begin GenNative(m_bit_imm, immediate, $0080, nil, 0); lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); GenNative(m_cmp_imm, immediate, $0000, nil, 0); end; {if} end; {if} end; cgLong, cgULong: begin if (A_X & gLong.preference) <> 0 then gLong.where := A_X else gLong.where := onStack; if opcode in [pc_gil,pc_gdl] then DoGIncDec(opcode, lab, op^.r, q); if not skipLoad then if smallMemoryModel then begin GenNative(m_ldx_abs, absolute, q+2, lab, 0); GenNative(m_lda_abs, absolute, q, lab, 0); if (opcode in [pc_gli,pc_gld]) and (op^.r <> 1) then gLong.where := onStack; if gLong.where = onStack then begin GenImplied(m_phx); GenImplied(m_pha); end; {if} end {if} else begin if opcode in [pc_gli,pc_gld] then gLong.where := onStack; GenNative(m_lda_long, longabsolute, q+2, lab, 0); if gLong.where = onStack then GenImplied(m_pha) else GenImplied(m_tax); GenNative(m_lda_long, longabsolute, q, lab, 0); if gLong.where = onStack then GenImplied(m_pha); end; {else} if opcode in [pc_gli,pc_gld] then DoGIncDec(opcode, lab, op^.r, q); end; {case cgLong,cgULong} otherwise: Error(cge1); end; {case} end; {GenGilGliGdlGld} procedure GenIilIliIdlIld (op: icptr); { Generate code for a pc_iil, pc_ili, pc_idl or pc_ild } var i: integer; {index variable} lab1: integer; {label} lSkipLoad: boolean; {copy of skipLoad} opcode: pcodes; {op^.opcode} short: boolean; {doing a one byte operand?} begin {GenIilIliIdlIld} opcode := op^.opcode; case op^.optype of cgByte,cgUByte,cgWord,cgUWord: begin short := op^.optype in [cgByte,cgUByte]; lSkipLoad := skipLoad; skipLoad := false; GetPointer(op^.left); skipLoad := lSkipLoad; if gLong.where = inPointer then begin if short then GenNative(m_sep, immediate, 32, nil, 0); if gLong.fixedDisp then GenNative(m_lda_indl, direct, gLong.disp, nil, 0) else GenNative(m_lda_indly, direct, gLong.disp, nil, 0); if opcode in [pc_ili,pc_iil] then GenImplied(m_ina) else GenImplied(m_dea); if gLong.fixedDisp then GenNative(m_sta_indl, direct, gLong.disp, nil, 0) else GenNative(m_sta_indly, direct, gLong.disp, nil, 0); if not skipLoad then if opcode = pc_ili then GenImplied(m_dea) else if opcode = pc_ild then GenImplied(m_ina); if short then GenNative(m_rep, immediate, 32, nil, 0); end {if} else if gLong.where = localAddress then begin gLong.disp := gLong.disp+op^.q; if gLong.fixedDisp then begin if short then GenNative(m_sep, immediate, 32, nil, 0); if (gLong.disp < 256) and (gLong.disp >= 0) then begin if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then GenNative(m_lda_dir, direct, gLong.disp, nil, 0); if opcode in [pc_ili,pc_iil] then GenNative(m_inc_dir, direct, gLong.disp, nil, 0) else GenNative(m_dec_dir, direct, gLong.disp, nil, 0); if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then GenNative(m_lda_dir, direct, gLong.disp, nil, 0); end {if} else begin GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); if opcode in [pc_ili,pc_iil] then GenNative(m_inc_dirX, direct, gLong.disp, nil, 0) else GenNative(m_dec_dirX, direct, gLong.disp, nil, 0); if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); end; {else} if short then GenNative(m_rep, immediate, 32, nil, 0); end else begin if (gLong.disp > 255) or (gLong.disp < 0) then begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenImplied(m_tax); gLong.disp := 0; end; {if} if short then GenNative(m_sep, immediate, 32, nil, 0); if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); if opcode in [pc_ili,pc_iil] then GenNative(m_inc_dirX, direct, gLong.disp, nil, 0) else GenNative(m_dec_dirX, direct, gLong.disp, nil, 0); if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); if short then GenNative(m_rep, immediate, 32, nil, 0); end; {else} end {else if} else {if gLong.where = globalLabel then} begin gLong.disp := gLong.disp+op^.q; if short then GenNative(m_sep, immediate, 32, nil, 0); if gLong.fixedDisp then if smallMemoryModel then begin if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0); if opcode in [pc_ili,pc_iil] then GenNative(m_inc_abs, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_dec_abs, absolute, gLong.disp, gLong.lab, 0); if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0); end {if} else begin GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0); if opcode in [pc_ili,pc_iil] then GenImplied(m_ina) else GenImplied(m_dea); GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0); if not skipLoad then if opcode = pc_ili then GenImplied(m_dea) else if opcode = pc_ild then GenImplied(m_ina); end {else} else if smallMemoryModel then begin if (not skipLoad) and (opcode in [pc_ili,pc_ild]) then GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0); if opcode in [pc_ili,pc_iil] then GenNative(m_inc_absX, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_dec_absX, absolute, gLong.disp, gLong.lab, 0); if (not skipLoad) and (opcode in [pc_iil,pc_idl]) then GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0); end {if} else begin GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0); if opcode in [pc_ili,pc_iil] then GenImplied(m_ina) else GenImplied(m_dea); GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0); if not skipLoad then if opcode = pc_ili then GenImplied(m_dea) else if opcode = pc_ild then GenImplied(m_ina); end; {else} if short then GenNative(m_rep, immediate, 32, nil, 0); end; {else} if not skipLoad then if short then GenNative(m_and_imm, immediate, $00FF, nil, 0); end; {case cgByte,cgUByte,cgWord,cgUWord} otherwise: Error(cge1); end; {case} end; {GenIilIliIdlIld} procedure GenIncDec (op, save: icptr); { generate code for pc_inc, pc_dec } { } { parameters: } { op - pc_inc or pc_dec operation } { save - save location (pc_str or pc_sro) or nil } var disp: integer; {disp in stack frame} lab1: integer; {branch point} opcode: pcodes; {temp storage for op code} size: integer; {number to increment by} clc,ina,adc: integer; {instructions to generate} begin {GenIncDec} {set up local variables} opcode := op^.opcode; size := op^.q; if op^.optype in [cgByte,cgUByte,cgWord,cgUWord] then begin GenTree(op^.left); if opcode = pc_inc then begin clc := m_clc; ina := m_ina; adc := m_adc_imm; end {if} else begin clc := m_sec; ina := m_dea; adc := m_sbc_imm; end; {else} if size = 1 then GenImplied(ina) else if size = 2 then begin GenImplied(ina); GenImplied(ina); end {else if} else if size <> 0 then begin GenImplied(clc); GenNative(adc, immediate, size, nil, 0); end; {else if} end {if} else if op^.optype in [cgLong,cgULong] then begin if SameLoc(op^.left, save) then begin lab1 := GenLabel; if size = 1 then begin if opcode = pc_inc then begin DoOp(0, m_inc_abs, m_inc_dir, op^.left, 0); GenNative(m_bne, relative, lab1, nil, 0); DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2); GenLab(lab1); end {if} else {if opcode = pc_dec then} begin DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0); GenNative(m_bne, relative, lab1, nil, 0); DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2); GenLab(lab1); DoOp(0, m_dec_abs, m_dec_dir, op^.left, 0); end; {else} end {if} else if opcode = pc_inc then begin GenImplied(m_clc); DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0); GenNative(m_adc_imm, immediate, size, nil, 0); DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0); GenNative(m_bcc, relative, lab1, nil, 0); DoOp(0, m_inc_abs, m_inc_dir, op^.left, 2); GenLab(lab1); end {else if} else begin GenImplied(m_sec); DoOp(m_lda_imm, m_lda_abs, m_lda_dir, op^.left, 0); GenNative(m_sbc_imm, immediate, size, nil, 0); DoOp(0, m_sta_abs, m_sta_dir, op^.left, 0); GenNative(m_bcs, relative, lab1, nil, 0); DoOp(0, m_dec_abs, m_dec_dir, op^.left, 2); GenLab(lab1); end; {else} end {if} else begin if save <> nil then gLong.preference := A_X else gLong.preference := gLong.preference & (A_X | inpointer); if opcode = pc_dec then gLong.preference := gLong.preference & A_X; GenTree(op^.left); if opcode = pc_inc then IncAddr(size) else begin lab1 := GenLabel; if gLong.where = A_X then begin GenImplied(m_sec); GenNative(m_sbc_imm, immediate, size, nil, 0); GenNative(m_bcs, relative, lab1, nil, 0); GenImplied(m_dex); end {if} else begin GenImplied(m_sec); GenNative(m_lda_s, direct, 1, nil, 0); GenNative(m_sbc_imm, immediate, size, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); GenNative(m_bcs, relative, lab1, nil, 0); GenNative(m_lda_s, direct, 3, nil, 0); GenImplied(m_dea); GenNative(m_sta_s, direct, 3, nil, 0); end; {else} GenLab(lab1); end; {else} if save <> nil then if save^.opcode = pc_str then begin disp := LabelToDisp(save^.r) + save^.q; if disp < 254 then begin if gLong.where = onStack then GenImplied(m_pla); GenNative(m_sta_dir, direct, disp, nil, 0); if gLong.where = onStack then GenImplied(m_plx); GenNative(m_stx_dir, direct, disp+2, nil, 0); end {else if} else begin if gLong.where = A_X then GenImplied(m_txy); GenNative(m_ldx_imm, immediate, disp, nil, 0); if gLong.where = onStack then GenImplied(m_pla); GenNative(m_sta_dirX, direct, 0, nil, 0); if gLong.where = onStack then GenImplied(m_pla) else GenImplied(m_tya); GenNative(m_sta_dirX, direct, 2, nil, 0); end; {else} end {else if} else {if save^.opcode = pc_sro then} begin if gLong.where = onStack then GenImplied(m_pla); if smallMemoryModel then GenNative(m_sta_abs, absolute, save^.q, save^.lab, 0) else GenNative(m_sta_long, longabsolute, save^.q, save^.lab, 0); if smallMemoryModel then begin if gLong.where = onStack then GenImplied(m_plx); GenNative(m_stx_abs, absolute, save^.q+2, save^.lab, 0) end {if} else begin if gLong.where = onStack then GenImplied(m_pla) else GenImplied(m_txa); GenNative(m_sta_long, longabsolute, save^.q+2, save^.lab, 0); end; {else} end; {else} end; {else} end; {else if} end; {GenIncDec} procedure GenInd (op: icptr); { Generate code for a pc_ind } var lab1: integer; {label} lLong: longType; {requested address type} optype: baseTypeEnum; {op^.optype} q: integer; {op^.q} begin {GenInd} optype := op^.optype; q := op^.q; case optype of cgReal,cgDouble,cgComp,cgExtended: begin gLong.preference := onStack; GenTree(op^.left); if q <> 0 then IncAddr(q); if optype = cgReal then GenCall(21) else if optype = cgDouble then GenCall(22) else if optype = cgComp then GenCall(70) else if optype = cgExtended then GenCall(71); end; {case cgReal,cgDouble,cgComp,cgExtended} cgLong,cgULong: begin lLong := gLong; GetPointer(op^.left); if gLong.where = inPointer then begin if q = 0 then begin if gLong.fixedDisp then begin GenNative(m_ldy_imm, immediate, 2, nil, 0); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); if (A_X & lLong.preference) <> 0 then GenImplied(m_tax) else GenImplied(m_pha); GenNative(m_lda_indl, direct, gLong.disp, nil, 0); end {if} else begin GenImplied(m_iny); GenImplied(m_iny); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); if (A_X & lLong.preference) <> 0 then GenImplied(m_tax) else GenImplied(m_pha); GenImplied(m_dey); GenImplied(m_dey); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); end; {else} if (A_X & lLong.preference) = 0 then GenImplied(m_pha); end {if q = 0} else begin if gLong.fixedDisp then begin GenNative(m_ldy_imm, immediate, q+2, nil, 0); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); if (A_X & lLong.preference) <> 0 then GenImplied(m_tax) else GenImplied(m_pha); GenNative(m_ldy_imm, immediate, q, nil, 0); end {if} else begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_imm, immediate, q+2, nil, 0); GenImplied(m_tay); GenNative(m_lda_indly, direct, gLong.disp, nil, 0); if (A_X & lLong.preference) <> 0 then GenImplied(m_tax) else GenImplied(m_pha); GenImplied(m_dey); GenImplied(m_dey); end; {else} GenNative(m_lda_indly, direct, gLong.disp, nil, 0); if (A_X & lLong.preference) = 0 then GenImplied(m_pha); end; {else} end {if glong.where = inPointer} else if gLong.where = localAddress then begin gLong.disp := gLong.disp+q; if gLong.fixedDisp then if (gLong.disp < 254) and (gLong.disp >= 0) then begin GenNative(m_lda_dir, direct, gLong.disp, nil, 0); GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0); end {if} else begin GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); GenNative(m_lda_dirX, direct, 0, nil, 0); GenNative(m_ldy_dirX, direct, 2, nil, 0); GenImplied(m_tyx); end {else} else begin if (gLong.disp >= 254) or (gLong.disp < 0) then begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenImplied(m_tax); gLong.disp := 0; end; {if} GenNative(m_ldy_dirX, direct, gLong.disp+2, nil, 0); GenNative(m_lda_dirX, direct, gLong.disp, nil, 0); GenImplied(m_tyx); end; {else} if (A_X & lLong.preference) = 0 then begin GenImplied(m_phx); GenImplied(m_pha); end; {if} end {else if gLong.where = localAddress} else {if gLong.where = globalLabel then} begin gLong.disp := gLong.disp+q; if gLong.fixedDisp then if smallMemoryModel then begin GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0); GenNative(m_ldx_abs, absolute, gLong.disp+2, gLong.lab, 0); end {if} else begin GenNative(m_lda_long, longAbs, gLong.disp+2, gLong.lab, 0); GenImplied(m_tax); GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0); end {else} else if smallMemoryModel then begin GenNative(m_ldy_absX, absolute, gLong.disp+2, gLong.lab, 0); GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0); GenImplied(m_tyx); end {if} else begin GenNative(m_lda_longX, longAbs, gLong.disp+2, gLong.lab, 0); GenImplied(m_tay); GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0); GenImplied(m_tyx); end; {else} if (A_X & lLong.preference) = 0 then begin GenImplied(m_phx); GenImplied(m_pha); end; {if} end; {else} if (A_X & lLong.preference) <> 0 then gLong.where := A_X else gLong.where := onStack; end; {cgLong,cgULong} cgByte,cgUByte,cgWord,cgUWord: begin GetPointer(op^.left); if gLong.where = inPointer then begin if q = 0 then if gLong.fixedDisp then GenNative(m_lda_indl, direct, gLong.disp, nil, 0) else GenNative(m_lda_indly, direct, gLong.disp, nil, 0) else if gLong.fixedDisp then begin GenNative(m_ldy_imm, immediate, q, nil, 0); GenNative(m_lda_indly, direct, gLong.disp, nil, 0) end {if} else begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_imm, immediate, q, nil, 0); GenImplied(m_tay); GenNative(m_lda_indly, direct, gLong.disp, nil, 0) end; {else} end {if} else if gLong.where = localAddress then begin gLong.disp := gLong.disp+q; if gLong.fixedDisp then if (gLong.disp & $FF00) = 0 then GenNative(m_lda_dir, direct, gLong.disp, nil, 0) else begin GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); GenNative(m_lda_dirX, direct, 0, nil, 0); end {else} else if (gLong.disp & $FF00) = 0 then GenNative(m_lda_dirX, direct, gLong.disp, nil, 0) else begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenImplied(m_tax); GenNative(m_lda_dirX, direct, 0, nil, 0); end {else} end {else if} else {if gLong.where = globalLabel then} begin gLong.disp := gLong.disp+q; if gLong.fixedDisp then if smallMemoryModel then GenNative(m_lda_abs, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_lda_long, longAbs, gLong.disp, gLong.lab, 0) else if smallMemoryModel then GenNative(m_lda_absX, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_lda_longX, longAbs, gLong.disp, gLong.lab, 0) end; {else} if optype in [cgByte,cgUByte] then begin GenNative(m_and_imm, immediate, 255, nil, 0); if optype = cgByte then begin GenNative(m_cmp_imm, immediate, 128, nil, 0); lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); end; {if} end; {if} end; {case cgByte,cgUByte,cgWord,cgUWord} otherwise: ; end; {case} end; {GenInd} procedure GenIxa (op: icptr); { Generate code for a pc_ixa } var lab1: integer; {branch label} lLong: longType; {type of address} zero: boolean; {is the index 0?} procedure Index; { Get the index size } var lLong: longType; {temp for preserving left node info} begin {Index} zero := false; with op^.right^ do begin if opcode = pc_ldc then begin if q = 0 then zero := true else GenNative(m_lda_imm, immediate, q, nil, 0); end {if} else begin lLong := gLong; GenTree(op^.right); gLong := lLong; end; {else} end; {with} end; {Index} begin {GenIxa} if smallMemoryModel then begin lLong := gLong; gLong.preference := inPointer+localAddress+globalLabel; GenTree(op^.left); case gLong.where of onStack: begin Index; if not zero then begin GenImplied(m_clc); GenNative(m_adc_s, direct, 1, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenNative(m_lda_s, direct, 3, nil, 0); GenImplied(m_ina); GenNative(m_sta_s, direct, 3, nil, 0); GenLab(lab1); end; {if} end; {case onStack} inPointer: begin if not gLong.fixedDisp then begin if Complex(op^.right) then begin GenImplied(m_phy); Index; if not zero then begin GenImplied(m_clc); GenNative(m_adc_s, direct, 1, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); end; {if} GenImplied(m_ply); end {if} else begin GenImplied(m_tya); GenImplied(m_clc); OperA(m_adc_imm, op^.right); GenImplied(m_tay); end; {else} end {if} else begin Index; if not zero then begin GenImplied(m_tay); gLong.fixedDisp := false; end; {if} end; {else} if (inPointer & lLong.preference) = 0 then begin if not gLong.fixedDisp then begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_dir, direct, gLong.disp, nil, 0); GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0); lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenImplied(m_inx); GenLab(lab1); end {if} else begin GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0); GenNative(m_lda_dir, direct, gLong.disp, nil, 0); end; {else} GenImplied(m_phx); GenImplied(m_pha); gLong.where := onStack; end; {if} end; {case inPointer} localAddress,globalLabel: begin if not gLong.fixedDisp then begin if Complex(op^.right) then begin GenImplied(m_phx); Index; if not zero then begin GenImplied(m_clc); GenNative(m_adc_s, direct, 1, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); end; {if} GenImplied(m_plx); end {if} else begin GenImplied(m_txa); GenImplied(m_clc); OperA(m_adc_imm, op^.right); GenImplied(m_tax); end; {else} end {if} else if Complex(op^.right) then begin Index; if not zero then begin GenImplied(m_tax); gLong.fixedDisp := false; end; {if} end {else if} else begin LoadX(op^.right); gLong.fixedDisp := false; end; {else} if (lLong.preference & gLong.where) = 0 then begin if (lLong.preference & inPointer) <> 0 then begin if gLong.where = localAddress then begin if not gLong.fixedDisp then begin GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0); GenImplied(m_phx); GenImplied(m_tdc); GenImplied(m_clc); if gLong.disp <> 0 then GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenNative(m_adc_s, direct, 1, nil, 0); GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenImplied(m_plx); end {if} else begin GenNative(m_stz_dir, direct, dworkLoc+2, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenNative(m_sta_dir, direct, dworkLoc, nil, 0); end; {else} end {if} else begin if not gLong.fixedDisp then begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0); GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16); lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenImplied(m_inx); GenLab(lab1); GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); end {if} else begin GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16); GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0); GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0); GenNative(m_sta_dir, direct, dworkLoc, nil, 0); end; {else} end; {else} gLong.where := inPointer; gLong.fixedDisp := true; gLong.disp := dworkLoc; end {if} else begin if gLong.where = localAddress then begin if not gLong.fixedDisp then begin GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_phx); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_s, direct, 1, nil, 0); if gLong.disp <> 0 then GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); end {if} else begin GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenImplied(m_pha); end; {else} end {if} else begin if not gLong.fixedDisp then begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0); GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16); lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenImplied(m_inx); GenLab(lab1); GenImplied(m_phx); GenImplied(m_pha); end {if} else begin GenNative(m_pea, immediate, gLong.disp, gLong.lab, shift16); GenNative(m_pea, immediate, gLong.disp, gLong.lab, 0); end; {else} end; {else} gLong.where := onStack; end; {else} end; {if} end; {case localAddress,globalLabel} otherwise: Error(cge1); end; {case} end {if smallMemoryModel or (op^.right^.opcode = pc_ldc)} else begin gLong.preference := onStack; GenTree(op^.left); GenTree(op^.right); if op^.optype in [cgByte,cgWord] then begin lab1 := GenLabel; GenNative(m_ldx_imm, immediate, $0000, nil, 0); GenImplied(m_tay); GenNative(m_bpl, relative, lab1, nil, 0); GenImplied(m_dex); GenLab(lab1); GenImplied(m_phx); GenImplied(m_pha); end {else if} else begin GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_pha); end; {else} GenImplied(m_clc); GenImplied(m_pla); GenNative(m_adc_s, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); GenImplied(m_pla); GenNative(m_adc_s, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); gLong.where := onStack; end; {else} end; {GenIxa} procedure GenLilLliLdlLld (op: icptr); { Generate code for a pc_lil, pc_lli, pc_ldl or pc_lld } var disp: integer; {load location} lab1: integer; {branch point} opcode: pcodes; {op^.opcode} procedure DoXIncDec (op: pcodes; p: integer); { Do a decrement or increment on a local four byte value X } { bytes into the stack frame } { } { parameters } { op - operation code } { p - number to ind/dec by } var lab1: integer; {branch point} begin {DoXIncDec} if op in [pc_lil,pc_lli] then begin lab1 := GenLabel; if p = 1 then begin GenNative(m_inc_dirx, direct, 0, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); end {if} else begin GenImplied(m_clc); GenNative(m_lda_dirx, direct, 0, nil, 0); GenNative(m_adc_imm, immediate, p, nil, 0); GenNative(m_sta_dirx, direct, 0, nil, 0); GenNative(m_bcc, relative, lab1, nil, 0); end; {else} GenNative(m_inc_dirx, direct, 2, nil, 0); GenLab(lab1); end {if} else {if op in [pc_gdl,pc_gld] then} begin lab1 := GenLabel; if p = 1 then begin GenNative(m_lda_dirx, direct, 0, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); GenNative(m_dec_dirx, direct, 2, nil, 0); GenLab(lab1); GenNative(m_dec_dirx, direct, 0, nil, 0); end {if} else begin GenImplied(m_sec); GenNative(m_lda_dirx, direct, 0, nil, 0); GenNative(m_sbc_imm, immediate, p, nil, 0); GenNative(m_sta_dirx, direct, 0, nil, 0); GenNative(m_bcs, relative, lab1, nil, 0); GenNative(m_dec_dirx, direct, 2, nil, 0); GenLab(lab1); end; {else} end; {else} end; {DoXIncDec} procedure DoLIncDec (op: pcodes; disp, p: integer); { Do a decrement or increment on a local four byte value } { } { parameters } { op - operation code } { disp - disp in stack frame to value } { p - number to ind/dec by } var lab1: integer; {branch point} begin {DoLIncDec} if op in [pc_lil,pc_lli] then begin lab1 := GenLabel; if p = 1 then begin GenNative(m_inc_dir, direct, disp, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); end {if} else begin GenImplied(m_clc); GenNative(m_lda_dir, direct, disp, nil, 0); GenNative(m_adc_imm, immediate, p, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); GenNative(m_bcc, relative, lab1, nil, 0); end; {else} GenNative(m_inc_dir, direct, disp+2, nil, 0); GenLab(lab1); end {if} else {if op in [pc_ldl,pc_lld] then} begin lab1 := GenLabel; if p = 1 then begin GenNative(m_lda_dir, direct, disp, nil, 0); GenNative(m_bne, relative, lab1, nil, 0); GenNative(m_dec_dir, direct, disp+2, nil, 0); GenLab(lab1); GenNative(m_dec_dir, direct, disp, nil, 0); end {if} else begin GenImplied(m_sec); GenNative(m_lda_dir, direct, disp, nil, 0); GenNative(m_sbc_imm, immediate, p, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); GenNative(m_bcs, relative, lab1, nil, 0); GenNative(m_dec_dir, direct, disp+2, nil, 0); GenLab(lab1); end; {else} end; {else} end; {DoLIncDec} begin {GenLilLliLdlLld} disp := LabelToDisp(op^.r); opcode := op^.opcode; case op^.optype of cgLong, cgULong: begin gLong.where := onStack; if disp >= 254 then begin GenNative(m_ldx_imm, immediate, disp, nil, 0); if opcode in [pc_lil,pc_ldl] then DoXIncDec(opcode, op^.q); if not skipLoad then begin GenNative(m_lda_dirx, direct, 2, nil, 0); GenImplied(m_pha); GenNative(m_lda_dirx, direct, 0, nil, 0); GenImplied(m_pha); end {if} else gLong.where := A_X; if opcode in [pc_lli,pc_lld] then DoXIncDec(opcode, op^.q); end {if} else begin if opcode in [pc_lil,pc_ldl] then DoLIncDec(opcode, disp, op^.q); if not skipLoad then begin GenNative(m_pei_dir, direct, disp+2, nil, 0); GenNative(m_pei_dir, direct, disp, nil, 0); end {if} else gLong.where := A_X; if opcode in [pc_lli,pc_lld] then DoLIncDec(opcode, disp, op^.q); end; {else} end; cgByte, cgUByte, cgWord, cgUWord: begin if op^.optype in [cgByte,cgUByte] then GenNative(m_sep, immediate, 32, nil, 0); if disp >= 256 then begin GenNative(m_ldx_imm, immediate, disp, nil, 0); if opcode = pc_lil then GenNative(m_inc_dirx, direct, 0, nil, 0) else if opcode = pc_ldl then GenNative(m_dec_dirx, direct, 0, nil, 0); if not skipLoad then GenNative(m_lda_dirx, direct, 0, nil, 0); if opcode = pc_lli then GenNative(m_inc_dirx, direct, 0, nil, 0) else if opcode = pc_lld then GenNative(m_dec_dirx, direct, 0, nil, 0); end else begin if opcode = pc_lil then GenNative(m_inc_dir, direct, disp, nil, 0) else if opcode = pc_ldl then GenNative(m_dec_dir, direct, disp, nil, 0); if not skipLoad then GenNative(m_lda_dir, direct, disp, nil, 0); if opcode = pc_lli then GenNative(m_inc_dir, direct, disp, nil, 0) else if opcode = pc_lld then GenNative(m_dec_dir, direct, disp, nil, 0); end; {else} if op^.optype in [cgByte,cgUByte] then begin GenNative(m_rep, immediate, 32, nil, 0); if not skipLoad then begin GenNative(m_and_imm, immediate, $00FF, nil, 0); if op^.optype = cgByte then begin GenNative(m_bit_imm, immediate, $0080, nil, 0); lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); GenNative(m_cmp_imm, immediate, $0000, nil, 0); end; {if} end; {if} end; {if} end; otherwise: Error(cge1); end; {case} end; {GenLilLliLdlLld} procedure GenLogic (op: icptr); { generate a pc_and, pc_ior, pc_bnd, pc_bor or pc_bxr } var lab1,lab2: integer; {label} nd: icptr; {temp node pointer} opcode: pcodes; {operation code} begin {GenLogic} opcode := op^.opcode; if opcode in [pc_and,pc_ior] then begin lab1 := GenLabel; GenTree(op^.left); GenNative(m_cmp_imm, immediate, 0, nil, 0); lab2 := GenLabel; if opcode = pc_and then GenNative(m_bne, relative, lab2, nil, 0) else begin GenNative(m_beq, relative, lab2, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); end; {else} GenNative(m_brl, longrelative, lab1, nil, 0); GenLab(lab2); GenTree(op^.right); GenNative(m_cmp_imm, immediate, 0, nil, 0); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenLab(lab1); end {if} else begin if not Complex(op^.left) then if Complex(op^.right) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} GenTree(op^.left); if Complex(op^.right) then begin GenImplied(m_pha); GenTree(op^.right); case opcode of pc_and,pc_bnd: GenNative(m_and_s, direct, 1, nil, 0); pc_ior,pc_bor: GenNative(m_ora_s, direct, 1, nil, 0); pc_bxr: GenNative(m_eor_s, direct, 1, nil, 0); otherwise: Error(cge1); end; {case} GenImplied(m_plx); GenImplied(m_tax); end {if} else case opcode of pc_and,pc_bnd: OperA(m_and_imm, op^.right); pc_ior,pc_bor: OperA(m_ora_imm, op^.right); pc_bxr: OperA(m_eor_imm, op^.right); otherwise: Error(cge1); end; {case} end; {else} end; {GenLogic} procedure GenSroCpo (op: icptr); { Generate code for a pc_sro or pc_cpo } var lab: stringPtr; {op^.lab} lab1: integer; {branch point} lval: longint; {op^.left^.lval} opcode: pcodes; {op^.opcode} optype: baseTypeEnum; {op^.optype} q: integer; {op^.q} special: boolean; {special save?} begin {GenSroCpo} opcode := op^.opcode; optype := op^.optype; q := op^.q; lab := op^.lab; case optype of cgByte, cgUByte: begin if smallMemoryModel and (op^.left^.opcode = pc_ldc) and (op^.left^.q = 0) and (opcode = pc_sro) then begin GenNative(m_sep, immediate, 32, nil, 0); GenNative(m_stz_abs, absolute, q, lab, 0); end {if} else begin if op^.opcode = pc_sro then if op^.left^.opcode = pc_cnv then if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then op^.left := op^.left^.left; if op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod] then begin GenNative(m_sep, immediate, 32, nil, 0); GenTree(op^.left); end {if} else begin GenTree(op^.left); GenNative(m_sep, immediate, 32, nil, 0); end; {else} if smallMemoryModel then GenNative(m_sta_abs, absolute, q, lab, 0) else GenNative(m_sta_long, longabsolute, q, lab, 0); end; {else} GenNative(m_rep, immediate, 32, nil, 0); end; cgWord, cgUWord: if smallMemoryModel and (op^.left^.opcode = pc_ldc) and (op^.left^.q = 0) and (opcode = pc_sro) then GenNative(m_stz_abs, absolute, q, lab, 0) else begin GenTree(op^.left); if smallMemoryModel then GenNative(m_sta_abs, absolute, q, lab, 0) else GenNative(m_sta_long, longabsolute, q, lab, 0); end; {else} cgReal, cgDouble, cgComp, cgExtended: begin GenTree(op^.left); GenNative(m_pea, immediate, q, lab, shift16); GenNative(m_pea, immediate, q, lab, 0); if opcode = pc_sro then begin if optype = cgReal then GenCall(9) else if optype = cgDouble then GenCall(10) else if optype = cgComp then GenCall(66) else {if optype = cgExtended then} GenCall(67); end {if} else {if opcode = pc_cpo then} begin if optype = cgReal then GenCall(51) else if optype = cgDouble then GenCall(52) else if optype = cgComp then GenCall(68) else {if optype = cgExtended then} GenCall(69); end; {else} end; cgLong, cgULong: begin if (opcode = pc_sro) and (op^.left^.opcode in [pc_adl,pc_sbl]) then GenAdlSbl(op^.left, op) else if (opcode = pc_sro) and (op^.left^.opcode in [pc_inc,pc_dec]) then GenIncDec(op^.left, op) else if smallMemoryModel and (op^.left^.opcode = pc_ldc) then begin lval := op^.left^.lval; if long(lval).lsw = 0 then GenNative(m_stz_abs, absolute, q, lab, 0) else begin GenNative(m_lda_imm, immediate, long(lval).lsw, nil, 0); GenNative(m_sta_abs, absolute, q, lab, 0) end; {else} if long(lval).msw = 0 then GenNative(m_stz_abs, absolute, q+2, lab, 0) else begin GenNative(m_ldx_imm, immediate, long(lval).msw, nil, 0); GenNative(m_stx_abs, absolute, q+2, lab, 0) end; {else} if op^.opcode = pc_cpo then GenTree(op^.left); end {if} else begin if op^.opcode = pc_sro then gLong.preference := A_X | inPointer | localAddress | globalLabel | constant else gLong.preference := gLong.preference & (A_X | inPointer | localAddress | globalLabel | constant); GenTree(op^.left); case gLong.where of A_X: begin if smallMemoryModel then begin GenNative(m_stx_abs, absolute, q+2, lab, 0); GenNative(m_sta_abs, absolute, q, lab, 0); end {if} else begin GenNative(m_sta_long, longabsolute, q, lab, 0); if opcode = pc_cpo then GenImplied(m_pha); GenImplied(m_txa); GenNative(m_sta_long, longabsolute, q+2, lab, 0); if opcode = pc_cpo then GenImplied(m_pla); end; {else} end; onStack: begin if opcode = pc_sro then GenImplied(m_pla) else {if opcode = pc_cpo then} GenNative(m_lda_s, direct, 1, nil, 0); if smallMemoryModel then GenNative(m_sta_abs, absolute, q, lab, 0) else GenNative(m_sta_long, longabsolute, q, lab, 0); if opcode = pc_sro then GenImplied(m_pla) else {if opcode = pc_cpo then} GenNative(m_lda_s, direct, 3, nil, 0); if smallMemoryModel then GenNative(m_sta_abs, absolute, q+2, lab, 0) else GenNative(m_sta_long, longabsolute, q+2, lab, 0); end; inPointer: begin GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0); if gLong.fixedDisp then GenNative(m_lda_dir, direct, gLong.disp, nil, 0) else begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_dir, direct, gLong.disp, nil, 0); if not smallMemoryModel then begin lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenImplied(m_inx); GenLab(lab1); end; {if} end; {else} if smallMemoryModel then begin GenNative(m_stx_abs, absolute, q+2, lab, 0); GenNative(m_sta_abs, absolute, q, lab, 0); end {if} else begin GenNative(m_sta_long, longabsolute, q, lab, 0); if opcode = pc_cpo then GenImplied(m_pha); GenImplied(m_txa); GenNative(m_sta_long, longabsolute, q+2, lab, 0); if opcode = pc_cpo then GenImplied(m_pla); end; {else} gLong.where := A_X; end; localAddress: begin if smallMemoryModel then GenNative(m_stz_abs, absolute, q+2, lab, 0) else begin GenNative(m_lda_imm, immediate, 0, nil, 0); GenNative(m_sta_long, longabsolute, q+2, lab, 0); end; {else} GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); if not gLong.fixedDisp then begin GenImplied(m_phx); GenNative(m_adc_s, direct, 1, nil, 0); GenImplied(m_plx); end; {if} if smallMemoryModel then GenNative(m_sta_abs, absolute, q, lab, 0) else GenNative(m_sta_long, longabsolute, q, lab, 0); end; globalLabel: if gLong.fixedDisp then begin if smallMemoryModel then begin GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0); GenNative(m_ldx_imm, immediate, gLong.disp, gLong.lab, shift16); GenNative(m_stx_abs, absolute, q+2, lab, 0); GenNative(m_sta_abs, absolute, q, lab, 0); end {if} else begin GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16); GenNative(m_sta_long, longabsolute, q+2, lab, 0); if opcode = pc_cpo then GenImplied(m_tax); GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0); GenNative(m_sta_long, longabsolute, q, lab, 0); end; {else} gLong.where := A_X; end {if} else begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0); if smallMemoryModel then GenNative(m_sta_abs, absolute, q, lab, 0) else GenNative(m_sta_long, longabsolute, q, lab, 0); GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16); GenNative(m_adc_imm, immediate, 0, nil, 0); if smallMemoryModel then GenNative(m_sta_abs, absolute, q+2, lab, 0) else GenNative(m_sta_long, longabsolute, q+2, lab, 0); end; {else} constant: begin if gLong.lval = 0 then begin if smallMemoryModel then begin GenNative(m_stz_abs, absolute, q+2, lab, 0); GenNative(m_stz_abs, absolute, q, lab, 0); end {if} else begin GenNative(m_lda_imm, immediate, 0, nil, 0); GenNative(m_sta_long, longabsolute, q+2, lab, 0); GenNative(m_sta_long, longabsolute, q, lab, 0); end; {else} end {if} else if not smallMemoryModel then begin GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0); GenNative(m_sta_long, longabsolute, q+2, lab, 0); GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0); GenNative(m_sta_long, longabsolute, q, lab, 0); end {else if} else begin if long(gLong.lval).msw = 0 then GenNative(m_stz_abs, absolute, q+2, lab, 0) else begin GenNative(m_ldx_imm, immediate, long(gLong.lval).msw, nil, 0); GenNative(m_stx_abs, absolute, q+2, lab, 0); end; {else} if long(gLong.lval).lsw = 0 then GenNative(m_stz_abs, absolute, q, lab, 0) else begin GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0); GenNative(m_sta_abs, absolute, q, lab, 0); end; {else} if (long(gLong.lval).lsw <> 0) and (long(gLong.lval).msw <> 0) then gLong.where := A_X; end; {else} end; {case constant} otherwise: Error(cge1); end; {case} end; {else} end; {case CGLong, cgULong} end; {case} end; {GenSroCpo} procedure GenStoCpi (op: icptr); { Generate code for a pc_sto or pc_cpi } var disp: integer; {disp in stack frame} opcode: pcodes; {temp storage for op code} optype: baseTypeEnum; {operand type} short: boolean; {use short registers?} simple: boolean; {is the load a simple load?} lLong: longType; {address record for left node} zero: boolean; {is the operand a constant zero?} procedure LoadLSW; { load the least significant word of a four byte value } begin {LoadLSW} if lLong.where = onStack then if opcode = pc_sto then GenImplied(m_pla) else GenNative(m_lda_s, direct, 1, nil, 0) else {if lLong.where = constant then} GenNative(m_lda_imm, immediate, long(lLong.lval).lsw, nil, 0); end; {LoadLSW} procedure LoadMSW; { load the most significant word of a four byte value } { } { Note: LoadLSW MUST be called first! } begin {LoadMSW} if lLong.where = onStack then if opcode = pc_sto then GenImplied(m_pla) else GenNative(m_lda_s, direct, 3, nil, 0) else {if lLong.where = constant then} GenNative(m_lda_imm, immediate, long(lLong.lval).msw, nil, 0); end; {LoadMSW} procedure LoadWord; { Get the operand for a cgByte, cgUByte, cgWord or cgUWord } { into the accumulator } begin {LoadWord} if simple then begin with op^.right^ do if opcode = pc_ldc then GenNative(m_lda_imm, immediate, q, nil, 0) else if opcode = pc_lod then GenNative(m_lda_dir, direct, LabelToDisp(r) + q, nil, 0) else {if opcode = pc_ldo then} if smallMemoryModel then GenNative(m_lda_abs, absolute, q, lab, 0) else GenNative(m_lda_long, longabsolute, q, lab, 0); end {if} else begin GenImplied(m_pla); if short then GenNative(m_sep, immediate, 32, nil, 0); end {else} end; {LoadWord} begin {GenStoCpi} opcode := op^.opcode; optype := op^.optype; case optype of cgReal,cgDouble,cgComp,cgExtended: begin GenTree(op^.right); gLong.preference := onStack; GenTree(op^.left); if optype = cgReal then begin if opcode = pc_sto then GenCall(9) else GenCall(51); end {if} else if optype = cgDouble then begin if opcode = pc_sto then GenCall(10) else GenCall(52); end {else if} else if optype = cgComp then begin if opcode = pc_sto then GenCall(66) else GenCall(68); end {else if} else {if optype = cgExtended then} begin if opcode = pc_sto then GenCall(67) else GenCall(69); end; {else} end; {case cgReal,cgDouble,cgComp,cgExtended} cgLong,cgULong: begin if opcode = pc_sto then gLong.preference := onStack+constant else gLong.preference := (onStack+constant) & gLong.preference; GenTree(op^.right); lLong := gLong; gLong.preference := localAddress+inPointer+globalLabel+A_X; GenTree(op^.left); if gLong.where = onStack then begin GenImplied(m_pla); GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenImplied(m_pla); GenNative(m_sta_dir, direct, dworkLoc+2, nil, 0); LoadLSW; GenNative(m_sta_indl, direct, dworkLoc, nil, 0); GenNative(m_ldy_imm, immediate, 2, nil, 0); LoadMSW; GenNative(m_sta_indly, direct, dworkLoc, nil, 0); end {if} else if gLong.where = A_X then begin GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenNative(m_stx_dir, direct, dworkLoc+2, nil, 0); LoadLSW; GenNative(m_sta_indl, direct, dworkLoc, nil, 0); GenNative(m_ldy_imm, immediate, 2, nil, 0); LoadMSW; GenNative(m_sta_indly, direct, dworkLoc, nil, 0); end {if} else if gLong.where = localAddress then begin LoadLSW; if gLong.fixedDisp then if (gLong.disp & $FF00) = 0 then GenNative(m_sta_dir, direct, gLong.disp, nil, 0) else begin GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); end {else} else begin if (gLong.disp >= 254) or (gLong.disp < 0) then begin GenImplied(m_tay); GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenImplied(m_tax); GenImplied(m_tya); gLong.disp := 0; end; {if} GenNative(m_sta_dirX, direct, gLong.disp, nil, 0); end; {else} LoadMSW; if gLong.fixedDisp then if ((gLong.disp+2) & $FF00) = 0 then GenNative(m_sta_dir, direct, gLong.disp+2, nil, 0) else begin GenNative(m_ldx_imm, immediate, gLong.disp+2, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); end {else} else begin if (gLong.disp >= 254) or (gLong.disp < 0) then begin GenImplied(m_tay); GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); GenImplied(m_tax); GenImplied(m_tya); gLong.disp := 0; end; {if} GenNative(m_sta_dirX, direct, gLong.disp+2, nil, 0); end; {else} end {else if} else if gLong.where = globalLabel then begin LoadLSW; if gLong.fixedDisp then if smallMemoryModel then GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0) else if smallMemoryModel then GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0); LoadMSW; if gLong.fixedDisp then if smallMemoryModel then GenNative(m_sta_abs, absolute, gLong.disp+2, gLong.lab, 0) else GenNative(m_sta_long, longAbs, gLong.disp+2, gLong.lab, 0) else if smallMemoryModel then GenNative(m_sta_absX, absolute, gLong.disp+2, gLong.lab, 0) else GenNative(m_sta_longX, longAbs, gLong.disp+2, gLong.lab, 0); end {else if} else begin LoadLSW; if gLong.fixedDisp = true then begin GenNative(m_sta_indl, direct, gLong.disp, nil, 0); GenNative(m_ldy_imm, immediate, 2, nil, 0); end {if} else begin GenNative(m_sta_indlY, direct, gLong.disp, nil, 0); GenImplied(m_iny); GenImplied(m_iny); end; {else} LoadMSW; GenNative(m_sta_indly, direct, gLong.Disp, nil, 0); end; {else} gLong := lLong; end; {case cgLong,cgULong} cgByte,cgUByte,cgWord,cgUWord: begin short := optype in [cgByte,cgUByte]; simple := false; zero := false; if op^.opcode = pc_sto then begin if short then if op^.right^.opcode = pc_cnv then if (op^.right^.q >> 4) in [ord(cgWord),ord(cgUWord)] then op^.right := op^.right^.left; with op^.right^ do begin if opcode = pc_ldo then simple := true else if opcode = pc_lod then simple := LabelToDisp(r) + q < 256 else if opcode = pc_ldc then begin simple := true; zero := q = 0; end; {else if} end; {with} end; {if} if not (zero or simple) then begin GenTree(op^.right); GenImplied(m_pha); end; {if} GetPointer(op^.left); if short then if simple then GenNative(m_sep, immediate, 32, nil, 0); if gLong.where = inPointer then begin if zero then GenNative(m_lda_imm, immediate, 0, nil, 0) else LoadWord; if gLong.fixedDisp then GenNative(m_sta_indl, direct, gLong.disp, nil, 0) else GenNative(m_sta_indlY, direct, gLong.disp, nil, 0); end {if} else if gLong.where = localAddress then begin if gLong.fixedDisp then if (gLong.disp & $FF00) = 0 then if zero then GenNative(m_stz_dir, direct, gLong.disp, nil, 0) else begin LoadWord; GenNative(m_sta_dir, direct, gLong.disp, nil, 0); end {else} else begin if zero then begin GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); GenNative(m_stz_dirX, direct, 0, nil, 0); end {if} else begin LoadWord; GenNative(m_ldx_imm, immediate, gLong.disp, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); end; {else} end {else} else begin if (gLong.disp & $FF00) <> 0 then begin GenImplied(m_txa); GenImplied(m_clc); GenNative(m_adc_imm, immediate, glong.disp, nil, 0); GenImplied(m_tax); gLong.disp := 0; end; {if} if zero then GenNative(m_stz_dirX, direct, gLong.disp, nil, 0) else begin LoadWord; GenNative(m_sta_dirX, direct, gLong.disp, nil, 0); end; {else} end; {else} end {else if} else {if gLong.where = globalLabel then} begin if zero then begin if not smallMemoryModel then GenNative(m_lda_imm, immediate, 0, nil, 0); end {if} else LoadWord; if gLong.fixedDisp then if smallMemoryModel then if zero then GenNative(m_stz_abs, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_sta_abs, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_sta_long, longAbs, gLong.disp, gLong.lab, 0) else if smallMemoryModel then if zero then GenNative(m_stz_absX, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_sta_absX, absolute, gLong.disp, gLong.lab, 0) else GenNative(m_sta_longX, longAbs, gLong.disp, gLong.lab, 0); end; {else} if short then begin GenNative(m_rep, immediate, 32, nil, 0); if opcode = pc_cpi then GenNative(m_and_imm, immediate, $00FF, nil, 0); end; {if} end; {case cgByte,cgUByte,cgWord,cgUWord} otherwise: Error(cge1); end; {case} end; {GenStoCpi} procedure GenStrCop (op: icptr); { Generate code for a pc_str or pc_cop } var disp: integer; {store location} optype: baseTypeEnum; {op^.optype} special: boolean; {use special processing?} zero: boolean; {is the operand a constant zero?} begin {GenStrCop} disp := LabelToDisp(op^.r) + op^.q; optype := op^.optype; case optype of cgByte, cgUByte, cgWord, cgUWord: begin zero := false; if op^.left^.opcode = pc_ldc then if op^.opcode = pc_str then if op^.left^.q = 0 then zero := true; if not zero then begin if optype in [cgByte,cgUByte] then begin if op^.opcode = pc_str then if op^.left^.opcode = pc_cnv then if (op^.left^.q >> 4) in [ord(cgWord),ord(cgUWord)] then op^.left := op^.left^.left; if (op^.left^.opcode in [pc_ldc,pc_ldc,pc_lod]) and (op^.opcode = pc_str) then begin GenNative(m_sep, immediate, 32, nil, 0); GenTree(op^.left); end {if} else begin GenTree(op^.left); GenNative(m_sep, immediate, 32, nil, 0); end; {else} end {if} else GenTree(op^.left); end {if} else if optype in [cgByte,cgUByte] then GenNative(m_sep, immediate, 32, nil, 0); if disp > 255 then begin GenNative(m_ldx_imm, immediate, disp, nil, 0); if zero then GenNative(m_stz_dirx, direct, 0, nil, 0) else GenNative(m_sta_dirx, direct, 0, nil, 0); end {if} else if zero then GenNative(m_stz_dir, direct, disp, nil, 0) else GenNative(m_sta_dir, direct, disp, nil, 0); if optype in [cgByte,cgUByte] then GenNative(m_rep, immediate, 32, nil, 0); end; cgReal, cgDouble, cgComp, cgExtended: begin GenTree(op^.left); GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, disp, nil, 0); GenImplied(m_pha); if op^.opcode = pc_str then begin if optype = cgReal then GenCall(9) else if optype = cgDouble then GenCall(10) else if optype = cgComp then GenCall(66) else {if optype = cgExtended then} GenCall(67); end {if} else begin if optype = cgReal then GenCall(51) else if optype = cgDouble then GenCall(52) else if optype = cgComp then GenCall(68) else {if optype = cgExtended then} GenCall(69); end; {else} end; cgLong, cgULong: begin if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_adl,pc_sbl]) then GenAdlSbl(op^.left, op) else if (op^.opcode = pc_str) and (op^.left^.opcode in [pc_inc,pc_dec]) then GenIncDec(op^.left, op) else begin if op^.opcode = pc_str then gLong.preference := A_X+onStack+inPointer+localAddress+globalLabel+constant else gLong.preference := onStack; GenTree(op^.left); case gLong.where of A_X: if disp < 254 then begin GenNative(m_stx_dir, direct, disp+2, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); end {else if} else begin GenImplied(m_txy); GenNative(m_ldx_imm, immediate, disp, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); GenNative(m_sty_dirX, direct, 2, nil, 0); if op^.opcode = pc_cop then GenImplied(m_tyx); end; {else} onStack: if disp < 254 then begin if op^.opcode = pc_str then GenImplied(m_pla) else {if op^.opcode = pc_cop then} GenNative(m_lda_s, direct, 1, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); if op^.opcode = pc_str then GenImplied(m_pla) else {if op^.opcode = pc_cop then} GenNative(m_lda_s, direct, 3, nil, 0); GenNative(m_sta_dir, direct, disp+2, nil, 0); end {else if} else begin GenNative(m_ldx_imm, immediate, disp, nil, 0); if op^.opcode = pc_str then GenImplied(m_pla) else {if op^.opcode = pc_cop then} GenNative(m_lda_s, direct, 1, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); if op^.opcode = pc_str then GenImplied(m_pla) else {if op^.opcode = pc_cop then} GenNative(m_lda_s, direct, 3, nil, 0); GenNative(m_sta_dirX, direct, 2, nil, 0); end; {else} inPointer: begin if (disp < 254) and (gLong.disp < 254) and gLong.fixedDisp and (disp >= 0) and (gLong.disp >= 0) then begin GenNative(m_lda_dir, direct, gLong.disp, nil, 0); GenNative(m_ldx_dir, direct, gLong.disp+2, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); GenNative(m_stx_dir, direct, disp+2, nil, 0); end {if} else if (disp < 254) and (gLong.disp < 254) and (disp >= 0) and (gLong.disp >= 0) and (op^.opcode = pc_str) then begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_dir, direct, gLong.disp, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0); GenNative(m_adc_imm, immediate, 0, nil, 0); GenNative(m_sta_dir, direct, disp+2, nil, 0); end {else if} else begin GenNative(m_ldx_imm, immediate, disp, nil, 0); if not gLong.fixedDisp then begin GenImplied(m_tya); GenImplied(m_clc); GenNative(m_adc_dir, direct, gLong.disp, nil, 0); end {if} else GenNative(m_lda_dir, direct, gLong.disp, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); GenNative(m_lda_dir, direct, gLong.disp+2, nil, 0); if not gLong.fixedDisp then GenNative(m_adc_imm, immediate, 0, nil, 0); GenNative(m_sta_dirX, direct, 2, nil, 0); end; {else} end; localAddress: if disp < 254 then begin GenNative(m_stz_dir, direct, disp+2, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); if not gLong.fixedDisp then begin GenImplied(m_phx); GenNative(m_adc_s, direct, 1, nil, 0); GenImplied(m_plx); end; {if} GenNative(m_sta_dir, direct, disp, nil, 0); end {else if disp < 254} else begin if not gLong.fixedDisp then GenImplied(m_phx); GenNative(m_ldx_imm, immediate, disp, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, nil, 0); if not gLong.fixedDisp then begin GenNative(m_adc_s, direct, 1, nil, 0); GenImplied(m_ply); end; {if} GenNative(m_sta_dirX, direct, 0, nil, 0); GenNative(m_stz_dirX, direct, 2, nil, 0); end; {else} globalLabel: begin if not gLong.fixedDisp then GenImplied(m_txa) else if disp > 253 then GenNative(m_ldx_imm, immediate, disp, nil, 0); if gLong.fixedDisp then GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, 0) else begin GenImplied(m_clc); GenNative(m_adc_imm, immediate, gLong.disp, gLong.lab, 0); end; {else} if disp < 254 then GenNative(m_sta_dir, direct, disp, nil, 0) else GenNative(m_sta_dirX, direct, 0, nil, 0); GenNative(m_lda_imm, immediate, gLong.disp, gLong.lab, shift16); if not gLong.fixedDisp then GenNative(m_adc_imm, immediate, 0, nil, 0); if disp < 254 then GenNative(m_sta_dir, direct, disp+2, nil, 0) else GenNative(m_sta_dirX, direct, 2, nil, 0); end; constant: if disp < 254 then begin GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0); GenNative(m_sta_dir, direct, disp, nil, 0); GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0); GenNative(m_sta_dir, direct, disp+2, nil, 0); end {else} else begin GenNative(m_ldx_imm, immediate, disp, nil, 0); GenNative(m_lda_imm, immediate, long(gLong.lval).lsw, nil, 0); GenNative(m_sta_dirX, direct, 0, nil, 0); GenNative(m_lda_imm, immediate, long(gLong.lval).msw, nil, 0); GenNative(m_sta_dirX, direct, 2, nil, 0); end; {else} otherwise: Error(cge1); end; {case} end; {else} end; otherwise: ; end; {case} end; {GenStrCop} procedure GenUnaryLong (op: icptr); { generate a pc_bnl or pc_ngl } begin {GenUnaryLong} gLong.preference := onStack; {get the operand} GenTree(op^.left); case op^.opcode of {do the operation} pc_bnl: begin GenNative(m_lda_s, direct, 1, nil, 0); GenNative(m_eor_imm, immediate, $FFFF, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); GenNative(m_lda_s, direct, 3, nil, 0); GenNative(m_eor_imm, immediate, $FFFF, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); end; {case pc_bnl} pc_ngl: begin GenImplied(m_sec); GenNative(m_lda_imm, immediate, 0, nil, 0); GenNative(m_sbc_s, direct, 1, nil, 0); GenNative(m_sta_s, direct, 1, nil, 0); GenNative(m_lda_imm, immediate, 0, nil, 0); GenNative(m_sbc_s, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); end; {case pc_ngl} end; {case} gLong.where := onStack; {the result is on the stack} end; {GenUnaryLong} procedure GenTree {op: icptr}; { generate code for op and its children } { } { parameters: } { op - opcode for which to generate code } procedure GenAdi (op: icptr); { generate a pc_adi } var nd: icptr; begin {GenAdi} if not Complex(op^.left) then if Complex(op^.right) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} GenTree(op^.left); if Complex(op^.right) then begin GenImplied(m_pha); GenTree(op^.right); GenImplied(m_clc); GenNative(m_adc_s, direct, 1, nil, 0); GenImplied(m_plx); end {if} else begin GenImplied(m_clc); OperA(m_adc_imm, op^.right); end; {else} end; {GenAdi} procedure GenBinLong (op: icptr); { generate one of: pc_blr, pc_blx, pc_bal, pc_dvl, pc_mdl, } { pc_mpl, pc_sll, pc_slr, pc_udl, pc_ulm, pc_uml, pc_vsr } var nd: icptr; {for swapping left/right children} procedure GenOp (ops, opi: integer); { generate a binary operation } { } { parameters: } { ops - stack version of operation } { opi - immediate version of operation } var lab1: integer; {label number} begin {GenOp} GenImplied(m_pla); if gLong.where = constant then begin GenNative(opi, immediate, long(gLong.lval).lsw, nil, 0); GenImplied(m_pha); GenNative(m_lda_s, direct, 3, nil, 0); GenNative(opi, immediate, long(gLong.lval).msw, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); end {if} else begin GenNative(ops, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); GenImplied(m_pla); GenNative(ops, direct, 3, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); end; {else} end; {GenOp} begin {GenBinLong} if (op^.left^.opcode = pc_ldc) and (op^.opcode in [pc_blr,pc_blx,pc_bal]) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} gLong.preference := onStack; GenTree(op^.left); if op^.opcode in [pc_blr,pc_blx,pc_bal] then begin gLong.preference := constant; GenTree(op^.right); end {if} else if op^.opcode in [pc_uml,pc_udl,pc_ulm] then begin gLong.preference := A_X; GenTree(op^.right); if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_plx); end; {if} end {else if} else begin gLong.preference := onStack; GenTree(op^.right); end; {else} case op^.opcode of pc_blr: GenOp(m_ora_s, m_ora_imm); pc_blx: GenOp(m_eor_s, m_eor_imm); pc_bal: GenOp(m_and_s, m_and_imm); pc_dvl: GenCall(43); pc_mdl: begin GenCall(44); GenImplied(m_ply); GenImplied(m_ply); end; pc_mpl: GenCall(42); pc_sll: GenCall(45); pc_slr: GenCall(47); pc_udl: GenCall(49); pc_ulm: GenCall(50); pc_uml: GenCall(48); pc_vsr: GenCall(46); otherwise: Error(cge1); end; {case} gLong.where := onStack; end; {GenBinLong} procedure GenBno (op: icptr); { Generate code for a pc_bno } var lLong: longType; {requested address type} begin {GenBno} lLong := gLong; GenTree(op^.left); gLong := lLong; GenTree(op^.right); end; {GenBno} procedure GenBntNgiNot (op: icptr); { Generate code for a pc_bnt, pc_ngi or pc_not } var lab1: integer; begin {GenntNgiNot} GenTree(op^.left); case op^.opcode of pc_bnt: GenNative(m_eor_imm, immediate, -1, nil, 0); pc_ngi: begin GenNative(m_eor_imm, immediate, -1, nil, 0); GenImplied(m_ina); end; {case pc_ngi} pc_not: begin lab1 := GenLabel; GenImplied(m_tax); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenLab(lab1); GenNative(m_eor_imm, immediate, 1, nil, 0); end; {if} end; {case} end; {GenBntNgiNot} procedure GenCui (op: icptr); { Generate code for a pc_cui } var lab1: integer; {return point} lLong: longType; {used to reserve gLong} begin {GenCup} {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_phx); GenImplied(m_tsx); GenNative(m_stx_dir, direct, stackLoc, nil, 0); end; {if} {generate parameters} {place the operands on the stack} lLong := gLong; GenTree(op^.left); {get the address to call} gLong.preference := onStack; GenTree(op^.right); gLong := lLong; {create a return label} lab1 := GenLabel; {place the call/return addrs on stack} GenNative(m_lda_s, direct, 1, nil, 0); GenImplied(m_dea); GenImplied(m_pha); GenNative(m_sep, immediate, 32, nil, 0); GenNative(m_lda_s, direct, 5, nil, 0); GenNative(m_sta_s, direct, 3, nil, 0); GenNative(m_lda_imm, genAddress, lab1, nil, shift16); GenNative(m_sta_s, direct, 6, nil, 0); GenNative(m_rep, immediate, 32, nil, 0); GenNative(m_lda_imm, genAddress, lab1, nil, 0); GenNative(m_sta_s, direct, 4, nil, 0); {indirect call} GenImplied(m_rtl); GenLab(lab1); if checkStack then begin {check the stack for errors} GenNative(m_ldy_dir, direct, stackLoc, nil, 0); GenCall(76); GenImplied(m_ply); GenNative(m_sty_dir, direct, stackLoc, nil, 0); end {if} else if saveStack or (op^.q <> 0) then begin GenImplied(m_txy); GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_txs); GenImplied(m_tyx); GenImplied(m_ply); GenNative(m_sty_dir, direct, stackLoc, nil, 0); end; {else} {save the returned value} gLong.where := A_X; SaveRetValue(op^.optype); end; {GenCui} procedure GenCup (op: icptr); { Generate code for a pc_cup } var lLong: longType; {used to reserve gLong} begin {GenCup} {save the stack register} if saveStack or checkStack or (op^.q <> 0) then begin GenNative(m_ldx_dir, direct, stackLoc, nil, 0); GenImplied(m_phx); GenImplied(m_tsx); GenNative(m_stx_dir, direct, stackLoc, nil, 0); end; {if} {generate parameters} lLong := gLong; GenTree(op^.left); gLong := lLong; {generate the jsl} GenNative(m_jsl, longAbs, 0, op^.lab, 0); {check the stack for errors} if checkStack then begin GenNative(m_ldy_dir, direct, stackLoc, nil, 0); GenCall(76); GenImplied(m_ply); GenNative(m_sty_dir, direct, stackLoc, nil, 0); GenImplied(m_tay); end {if} else if saveStack or (op^.q <> 0) then begin GenImplied(m_tay); GenNative(m_lda_dir, direct, stackLoc, nil, 0); GenImplied(m_tcs); GenImplied(m_pla); GenNative(m_sta_dir, direct, stackLoc, nil, 0); GenImplied(m_tya); end; {else} {save the returned value} gLong.where := A_X; SaveRetValue(op^.optype); end; {GenCup} procedure GenDviMod (op: icptr); { Generate code for a pc_dvi, pc_mod, pc_udi or pc_uim } var opcode: pcodes; {temp storage} begin {GenDviMod} if Complex(op^.right) then begin GenTree(op^.right); if Complex(op^.left) then begin GenImplied(m_pha); GenTree(op^.left); GenImplied(m_plx); end {if} else begin GenImplied(m_tax); GenTree(op^.left); end; {else} end {if} else begin GenTree(op^.left); LoadX(op^.right); end; {else} opcode := op^.opcode; if opcode = pc_mod then GenCall(27) else if opcode = pc_dvi then GenCall(26) else {if opcode in [pc_udi,pc_uim] then} begin GenCall(40); if opcode = pc_uim then GenImplied(m_txa); end; {else} if rangeCheck then GenCall(25); end; {GenDviMod} procedure GenEnt; { Generate code for a pc_ent } begin {GenEnt} if rangeCheck then begin {if range checking is on, check for a stack overflow} GenNative(m_pea, immediate, localSize - returnSize - 1, nil, 0); GenCall(1); end; {if} if localSize = 0 then begin {create the stack frame} if parameterSize <> 0 then begin GenImplied(m_tsc); GenImplied(m_phd); GenImplied(m_tcd); end; {if} end {if} else if localSize = 2 then begin GenImplied(m_pha); GenImplied(m_tsc); GenImplied(m_phd); GenImplied(m_tcd); end {else if} else begin GenImplied(m_tsc); GenImplied(m_sec); GenNative(m_sbc_imm, immediate, localSize, nil, 0); GenImplied(m_tcs); GenImplied(m_phd); GenImplied(m_tcd); end; {if} if dataBank then begin {preserve and set data bank} GenImplied(m_phb); GenImplied(m_phb); GenImplied(m_pla); GenNative(m_sta_dir, direct, bankLoc, nil, 0); GenNative(m_pea, immediate, 0, @'~GLOBALS', shift8); GenImplied(m_plb); GenImplied(m_plb); end; {if} {no pc_nam (yet)} namePushed := false; end; {GenEnt} procedure GenFjpTjp (op: icptr); { Generate code for a pc_fjp or pc_tjp } var lab1: integer; {branch point} opcode: pcodes; {op^.left^.opcode} begin {GenFjpTjp} if op^.left^.opcode in [pc_equ,pc_geq,pc_grt,pc_les,pc_leq,pc_neq] then if op^.left^.opcode in [pc_equ,pc_neq] then GenEquNeq(op^.left, op^.opcode, op^.q) else GenCmp(op^.left, op^.opcode, op^.q) else begin lab1 := GenLabel; GenTree(op^.left); opcode := op^.left^.opcode; if NeedsCondition(opcode) then GenImplied(m_tax) else if opcode = pc_ind then if op^.left^.optype in [cgByte,cgUByte] then GenImplied(m_tax); if op^.opcode = pc_fjp then GenNative(m_bne, relative, lab1, nil, 0) else {if op^.opcode = pc_tjp then} GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_brl, longrelative, op^.q, nil, 0); GenLab(lab1); end; {else} end; {GenFjpTjp} procedure GenLaoLad (op: icptr); { Generate code for a pc_lao, pc_lad } var q: integer; {displacement} begin {GenLaoLad} if op^.opcode = pc_lad then q := 0 else q := op^.q; if (globalLabel & gLong.preference) <> 0 then begin gLong.fixedDisp := true; gLong.where := globalLabel; gLong.disp := q; gLong.lab := op^.lab; end {if} else if (A_X & gLong.preference) <> 0 then begin gLong.where := A_X; GenNative(m_ldx_imm, immediate, q, op^.lab, shift16); GenNative(m_lda_imm, immediate, q, op^.lab, 0); end {else if} else begin gLong.where := onStack; GenNative(m_pea, immediate, q, op^.lab, shift16); GenNative(m_pea, immediate, q, op^.lab, 0); end; {else} end; {GenLaoLad} procedure GenLbfLbu (op: icptr); { Generate code for a pc_lbf or pc_lbu } var lLong: longType; {requested address type} begin {GenLbfLbu} lLong := gLong; gLong.preference := onStack; GenTree(op^.left); GenNative(m_pea, immediate, op^.r, nil, 0); GenNative(m_pea, immediate, op^.q, nil, 0); if op^.opcode = pc_lbf then GenCall(73) else GenCall(72); if op^.optype in [cgLong,cgULong] then begin if (A_X & lLong.preference) <> 0 then gLong.where := A_X else begin gLong.where := onStack; GenImplied(m_phx); GenImplied(m_pha); end; {else} end; {if} end; {GenLbfLbu} procedure GenLca (op: icptr); { Generate code for a pc_lca } var i: integer; {loop/index variable} begin {GenLca} gLong.where := onStack; GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16); GenNative(m_pea, immediate, stringSize, nil, stringReference); if maxString-stringSize >= op^.q+1 then begin for i := 1 to op^.q do stringSpace[i+stringSize] := op^.str^.str[i]; stringSpace[stringSize+op^.q+1] := chr(0); stringSize := stringSize+op^.q+1; end else Error(cge3); op^.optype := cgULong; end; {GenLca} procedure GenLda (op: icptr); { Generate code for a pc_lda } begin {GenLda} if (localAddress & gLong.preference) <> 0 then begin gLong.fixedDisp := true; gLong.where := localAddress; gLong.disp := LabelToDisp(op^.r) + op^.q; end {if} else if (A_X & gLong.preference) <> 0 then begin gLong.where := A_X; GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, LabelToDisp(op^.r) + op^.q, nil, 0); GenNative(m_ldx_imm, immediate, 0, nil, 0); end {else if} else begin gLong.where := onStack; GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, LabelToDisp(op^.r) + op^.q, nil, 0); GenImplied(m_pha); end; {else} end; {GenLda} procedure GenLdc (op: icptr); { Generate code for a pc_ldc } type kind = (vint, vbyte, vreal); {kinds of equivalenced data} var i: integer; {loop/index variable} rec: realrec; {conversion record} switch: packed record {used for type conversion} case rkind: kind of vint: (i: integer); vbyte: (b1, b2, b3, b4, b5, b6, b7, b8: byte); vreal: (r: double); end; begin {GenLdc} case op^.optype of cgByte: begin if op^.q > 127 then op^.q := op^.q | $FF00; GenNative(m_lda_imm, immediate, op^.q, nil, 0); end; cgUByte, cgWord, cgUWord: GenNative(m_lda_imm, immediate, op^.q, nil, 0); cgReal, cgDouble, cgComp, cgExtended: begin rec.itsReal := op^.rval; CnvSX(rec); i := 9; while i >= 0 do begin switch.b1 := rec.inSANE[i]; switch.b2 := rec.inSANE[i+1]; GenNative(m_pea, immediate, switch.i, nil, 0); i := i-2; end; {while} end; cgLong, cgULong: if (constant & gLong.preference) <> 0 then begin gLong.where := constant; gLong.lval := op^.lval; end else if (A_X & gLong.preference) <> 0 then begin gLong.where := A_X; GenNative(m_lda_imm, immediate, long(op^.lval).lsw, nil, 0); GenNative(m_ldx_imm, immediate, long(op^.lval).msw, nil, 0); end else begin gLong.where := onStack; GenNative(m_pea, immediate, long(op^.lval).msw, nil, 0); GenNative(m_pea, immediate, long(op^.lval).lsw, nil, 0); end; otherwise: Error(cge1); end; {case} end; {GenLdc} procedure GenLdo (op: icptr); { Generate code for a pc_ldo } var lab1: integer; {branch point} begin {GenLdo} case op^.optype of cgWord, cgUWord: if smallMemoryModel then GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0) else GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0); cgByte, cgUByte: begin if smallMemoryModel then GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0) else GenNative(m_lda_long, longAbs, op^.q, op^.lab, 0); GenNative(m_and_imm, immediate, 255, nil, 0); if op^.optype = cgByte then begin GenNative(m_bit_imm, immediate, $0080, nil, 0); lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); GenNative(m_cmp_imm, immediate, $0000, nil, 0); end; {if} end; cgReal, cgDouble, cgComp, cgExtended: begin GenNative(m_pea, immediate, op^.q, op^.lab, shift16); GenNative(m_pea, immediate, op^.q, op^.lab, 0); if op^.optype = cgReal then GenCall(21) else if op^.optype = cgDouble then GenCall(22) else if op^.optype = cgComp then GenCall(70) else {if op^.optype = cgExtended then} GenCall(71); end; cgLong, cgULong: begin if (A_X & gLong.preference) <> 0 then gLong.where := A_X else gLong.where := onStack; if smallMemoryModel then begin GenNative(m_ldx_abs, absolute, op^.q+2, op^.lab, 0); GenNative(m_lda_abs, absolute, op^.q, op^.lab, 0); if gLong.where = onStack then begin GenImplied(m_phx); GenImplied(m_pha); end; {if} end {if} else begin GenNative(m_lda_long, longabsolute, op^.q+2, op^.lab, 0); if gLong.where = onStack then GenImplied(m_pha) else GenImplied(m_tax); GenNative(m_lda_long, longabsolute, op^.q, op^.lab, 0); if gLong.where = onStack then GenImplied(m_pha); end; {else} end; {case cgLong,cgULong} otherwise: Error(cge1); end; {case} end; {GenLdo} procedure GenLnm (op: icptr); { Generate code for a pc_lnm } begin {GenLnm} if op^.left <> nil then GenTree(op^.left); if traceBack then begin GenNative(m_pea, immediate, op^.r, nil, 0); GenCall(6); end; {if} if debugFlag then begin GenNative(m_cop, immediate, op^.q, nil, 0); GenNative(d_wrd, special, op^.r, nil, 0); end; {if} end; {GenLnm} procedure GenLod (op: icptr); { Generate code for a pc_lod } var disp: integer; {load location} lab1: integer; {branch point} optype: baseTypeEnum; {op^.optype} begin {GenLod} disp := LabelToDisp(op^.r) + op^.q; optype := op^.optype; case optype of cgReal, cgDouble, cgComp, cgExtended: begin GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, disp, nil, 0); GenImplied(m_pha); if optype = cgReal then GenCall(21) else if optype = cgDouble then GenCall(22) else if optype = cgComp then GenCall(70) else {if optype = cgExtended then} GenCall(71); end; cgLong, cgULong: begin if ((inPointer & gLong.preference) <> 0) and (disp < 254) then begin gLong.where := inPointer; gLong.fixedDisp := true; gLong.disp := disp; end {if} else if ((A_X & gLong.preference) <> 0) and (disp < 254) then begin gLong.where := A_X; GenNative(m_ldx_dir, direct, disp+2, nil, 0); GenNative(m_lda_dir, direct, disp, nil, 0); end {else if} else begin gLong.where := onStack; if disp >= 254 then begin GenNative(m_ldx_imm, immediate, disp, nil, 0); GenNative(m_lda_dirx, direct, 2, nil, 0); GenImplied(m_pha); GenNative(m_lda_dirx, direct, 0, nil, 0); GenImplied(m_pha); end {if} else begin GenNative(m_pei_dir, direct, disp+2, nil, 0); GenNative(m_pei_dir, direct, disp, nil, 0); end; {else} end; {else} end; cgByte, cgUByte, cgWord, cgUWord: begin if disp >= 256 then begin GenNative(m_ldx_imm, immediate, disp, nil, 0); GenNative(m_lda_dirx, direct, 0, nil, 0); end else GenNative(m_lda_dir, direct, disp, nil, 0); if optype in [cgByte,cgUByte] then begin GenNative(m_and_imm, immediate, $00FF, nil, 0); if optype = cgByte then begin GenNative(m_bit_imm, immediate, $0080, nil, 0); lab1 := GenLabel; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_ora_imm, immediate, $FF00, nil, 0); GenLab(lab1); GenNative(m_cmp_imm, immediate, $0000, nil, 0); end; {if} end; end; otherwise: Error(cge1); end; {case} end; {GenLod} procedure GenLorLnd (op: icptr); { Generate code for a pc_lor or pc_lnd } var lab1,lab2: integer; {label} nd: icptr; {temp node pointer} opc: pcodes; {operation code} procedure DoOra; { do some common oring operations to reduce space } begin {DoOra} if gLong.where = onStack then begin GenImplied(m_pla); GenNative(m_sta_dir, direct, dworkLoc, nil, 0); GenImplied(m_pla); end {if} else GenNative(m_stx_dir, direct, dworkLoc, nil, 0); GenNative(m_ora_dir, direct, dworkLoc, nil, 0); end; {DoOra} begin {GenLorLnd} opc := op^.opcode; lab1 := GenLabel; gLong.preference := A_X; GenTree(op^.left); DoOra; lab2 := GenLabel; if opc = pc_lnd then GenNative(m_bne, relative, lab2, nil, 0) else begin GenNative(m_beq, relative, lab2, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); end; {else} GenNative(m_brl, longrelative, lab1, nil, 0); GenLab(lab2); gLong.preference := A_X; GenTree(op^.right); DoOra; GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, 1, nil, 0); GenLab(lab1); end; {GenLorLnd} procedure GenMov (op: icptr; duplicate: boolean); { Generate code for a pc_mov } { } { parameters: } { op - pc_mov instruction } { duplicate - should the source address be left on the } { stack? } var banks: integer; {number of banks to move} procedure Load (opcode: integer; op: icptr); { generate a load immediate based on instruction type } { } { parameters: } { opcode - native code load operation } { op - node to load } var i: integer; begin {Load} if op^.opcode = pc_lao then GenNative(opcode, immediate, op^.q, op^.lab, 0) else begin GenNative(opcode, immediate, stringsize, nil, StringReference); if maxstring-stringsize >= op^.q then begin for i := 1 to op^.q do stringspace[i+stringsize] := op^.str^.str[i]; stringsize := stringsize + op^.q; end {if} else Error(cge3); end; {else} end; {Load} begin {GenMov} {determine if the destination address must be left on the stack} if smallMemoryModel and (not duplicate) and (op^.left^.opcode in [pc_lao,pc_lca]) and (op^.right^.opcode in [pc_lao,pc_lca]) then begin {take advantage of any available short cuts} Load(m_ldy_imm, op^.left); Load(m_ldx_imm, op^.right); GenNative(m_lda_imm, immediate, op^.q-1, nil, 0); GenImplied(m_phb); GenImplied(m_mvn); with op^.left^ do if opcode = pc_lao then GenNative(d_bmov, immediate, q, lab, shift16) else GenNative(d_bmov, immediate, 0, nil, stringReference+shift16); with op^.right^ do if opcode = pc_lao then GenNative(d_bmov, immediate, q, lab, shift16) else GenNative(d_bmov, immediate, 0, nil, stringReference+shift16); GenImplied(m_plb); end {if} else begin {no short cuts are available - do it the hard way} gLong.preference := onStack; GenTree(op^.left); gLong.preference := onStack; GenTree(op^.right); banks := op^.r; if banks <> 0 then GenNative(m_pea, immediate, banks, nil, 0); GenNative(m_pea, immediate, op^.q, nil, 0); if banks = 0 then begin if duplicate then GenCall(55) else GenCall(54); end {if} else if duplicate then GenCall(63) else GenCall(62); end; {else} end; {GenMov} procedure GenMpi (op: icptr); { Generate code for a pc_mpi or pc_umi } var nd: icptr; begin {GenMpi} if not Complex(op^.left) then if Complex(op^.right) then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} GenTree(op^.left); if Complex(op^.right) then begin GenImplied(m_pha); GenTree(op^.right); GenImplied(m_plx); end {if} else LoadX(op^.right); if op^.opcode = pc_mpi then GenCall(28) else {pc_umi} GenCall(39); if rangeCheck then GenCall(25); end; {GenMpi} procedure GenNam (op: icptr); { Generate code for a pc_nam } var i: integer; {loop/index variable} len: integer; {length of the file name} function ToUpper (ch: char): char; { Return the uppercase equivalent of the input character } begin {ToUpper} if (ch >= 'a') and (ch <= 'z') then ch := chr(ord(ch)-ord('a')+ord('A')); ToUpper := ch; end; {ToUpper} begin {GenNam} {generate a call to install the name in the traceback facility} if traceBack then begin GenNative(m_pea, immediate, stringSize, nil, stringReference+shift16); GenNative(m_pea, immediate, stringSize, nil, stringReference); GenCall(5); namePushed := true; end; {if} {send the name to the profiler} if profileFlag then begin GenNative(m_cop, immediate, 3, nil, 0); GenNative(d_add, genaddress, stringSize, nil, stringReference); GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16); end; {if} {place the name in the string buffer} if maxString-stringSize >= op^.q+1 then begin stringSpace[stringSize+1] := chr(op^.q); for i := 1 to op^.q do stringSpace[i+stringSize+1] := op^.str^.str[i]; stringSize := stringSize + op^.q + 1; end {if} else Error(cge3); {send the file name to the debugger} if debugFlag then begin GenNative(m_cop, immediate, 6, nil, 0); GenNative(d_add, genaddress, stringSize, nil, stringReference); GenNative(d_add, genaddress, stringSize, nil, stringReference+shift16); len := sourceFileGS.theString.size; if len > 255 then len := 255; if maxString-stringSize >= len+1 then begin stringSpace[stringSize+1] := chr(len); for i := 1 to len do stringSpace[i+stringSize+1] := ToUpper(sourceFileGS.theString.theString[i]); stringSize := stringSize + len + 1; end {if} else Error(cge3); end; {if} end; {GenNam} procedure GenNat (op: icptr); { Generate code for a pc_nat } var flags: integer; {work var for flags} mode: addressingmode; {work var for addressing mode} pval: longint; {temp pointer} val: longint; {constant operand} begin {GenNat} val := op^.opnd; flags := op^.q; pval := op^.llab; mode := addressingMode(op^.r); if op^.slab <> 0 then val := val+LabelToDisp(op^.slab); if mode in [relative,longrelative] then GenNative(op^.s, mode, op^.llab, op^.lab, op^.q) else if (mode = longabsolute) and (op^.llab <> 0) then GenNative(op^.s, mode, long(val).lsw, pointer(pval), flags | localLab) else if (mode = longabsolute) and (op^.llab = 0) and (op^.lab = nil) then GenNative(op^.s, mode, 0, pointer(val), flags | constantOpnd) else begin if (mode = absolute) and (op^.llab = 0) then flags := flags | constantOpnd; if op^.llab <> 0 then GenNative(op^.s, mode, long(val).lsw, pointer(pval), flags | localLab) else GenNative(op^.s, mode, long(val).lsw, op^.lab, flags); end; {else} end; {GenNat} procedure GenNgr (op: icptr); { Generate code for a pc_ngr } begin {GenNgr} GenTree(op^.left); GenNative(m_lda_s, direct, 9, nil, 0); GenNative(m_eor_imm, immediate, -32767-1, nil, 0); GenNative(m_sta_s, direct, 9, nil, 0); end; {GenNgr} procedure GenPop (op: icptr); { Generate code for a pc_pop } var isIncLoad: boolean; {is the operand one of the inc/dec & load commands?} begin {GenPop} glong.preference := A_X; {generate the operand} isIncLoad := op^.left^.opcode in [pc_lil,pc_lli,pc_ldl,pc_lld,pc_gil,pc_gli,pc_gdl,pc_gld, pc_iil,pc_ili,pc_idl,pc_ild]; if isIncLoad then skipLoad := true; if op^.left^.opcode = pc_mov then GenMov(op^.left, false) else begin GenTree(op^.left); if isIncLoad then skipLoad := false; case op^.optype of {do the pop} otherwise: ; cgLong, cgULong: if not isIncLoad then if gLong.where = onStack then begin GenImplied(m_pla); GenImplied(m_pla); end; {if} {else do nothing} cgReal, cgDouble, cgComp, cgExtended: begin GenImplied(m_tsc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, 10, nil, 0); GenImplied(m_tcs); end; end; {case} end; {else} end; {GenPop} procedure GenPsh (op: icptr); { Generate code for a pc_psh } begin {GenPsh} gLong.preference := onStack; GenTree(op^.left); GenTree(op^.right); GenImplied(m_pha); GenCall(77); end; {GenPsh} procedure GenRealBinOp (op: icptr); { Generate code for a pc_adr, pc_dvr, pc_mpr or pc_sbr } var nd: icptr; {temp pointer} snum: integer; {library subroutine numbers} ss,sd,sc,se: integer; {sane call numbers} begin {GenRealBinOp} case op^.opcode of pc_adr: begin snum := 56; ss := $0200; sd := $0100; sc := $0500; se := $0000; end; pc_dvr: begin snum := 57; ss := $0206; sd := $0106; sc := $0506; se := $0006; end; pc_mpr: begin snum := 58; ss := $0204; sd := $0104; sc := $0504; se := $0004; end; pc_sbr: begin snum := 59; ss := $0202; sd := $0102; sc := $0502; se := $0002; end; end; {case} if op^.opcode in [pc_mpr,pc_adr] then if op^.left^.opcode in [pc_lod,pc_ldo] then begin nd := op^.left; op^.left := op^.right; op^.right := nd; end; {if} GenTree(op^.left); if (op^.right^.opcode in [pc_lod,pc_ldo]) and (floatCard = 0) then with op^.right^ do begin if opcode = pc_lod then begin GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_tdc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, LabelToDisp(r) + q, nil, 0); GenImplied(m_pha); end {if} else begin GenNative(m_pea, immediate, q, lab, shift16); GenNative(m_pea, immediate, q, lab, 0); end; {else} GenNative(m_pea, immediate, 0, nil, 0); GenImplied(m_tsc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, 7, nil, 0); GenImplied(m_pha); if optype = cgReal then sd := ss else if optype = cgExtended then sd := se else if optype = cgComp then sd := sc; GenNative(m_pea, immediate, sd, nil, 0); GenNative(m_ldx_imm, immediate, $090A, nil, 0); GenNative(m_jsl, longAbs, 0, nil, toolCall); end {with} else begin GenTree(op^.right); GenCall(snum); end; {else} end; {GenRealBinOp} procedure GenRet (op: icptr); { Generate code for a pc_ret } var size: integer; {localSize + parameterSize} begin {GenRet} {pop the name record} if namePushed then GenCall(2); {generate an exit code for the debugger's benefit} if debugFlag then GenNative(m_cop, immediate, 4, nil, 0); {if anything needs to be removed from the stack, move the return val} size := localSize + parameterSize; if parameterSize <> 0 then begin if localSize > 254 then begin GenNative(m_ldx_imm, immediate, localSize+1, nil, 0); GenNative(m_lda_dirx, direct, 0, nil, 0); GenNative(m_ldy_dirx, direct, 1, nil, 0); GenNative(m_ldx_imm, immediate, localSize+parameterSize+1, nil, 0); GenNative(m_sta_dirx, direct, 0, nil, 0); GenNative(m_sty_dirx, direct, 1, nil, 0); end {if} else begin GenNative(m_lda_dir, direct, localSize+2, nil, 0); if localSize+parameterSize > 254 then begin GenNative(m_ldx_imm, immediate, localSize+parameterSize+1, nil, 0); GenNative(m_sta_dirx, direct, 1, nil, 0); GenNative(m_lda_dir, direct, localSize+1, nil, 0); GenNative(m_sta_dirx, direct, 0, nil, 0); end {if} else begin GenNative(m_sta_dir, direct, localSize+parameterSize+2, nil, 0); GenNative(m_lda_dir, direct, localSize+1, nil, 0); GenNative(m_sta_dir, direct, localSize+parameterSize+1, nil, 0); end; {else} end; {else} end; {if} {load the value to return} case op^.optype of cgVoid: ; cgByte,cgUByte: begin GenNative(m_lda_dir, direct, funLoc, nil, 0); GenNative(m_and_imm, immediate, $00FF, nil, 0); if size <> 2 then GenImplied(m_tay); end; cgWord,cgUWord: if size = 2 then GenNative(m_lda_dir, direct, funLoc, nil, 0) else GenNative(m_ldy_dir, direct, funLoc, nil, 0); cgReal: GenCall(3); cgDouble: GenCall(4); cgComp: GenCall(64); cgExtended: GenCall(65); cgLong,cgULong: begin GenNative(m_ldx_dir, direct, funLoc+2, nil, 0); GenNative(m_ldy_dir, direct, funLoc, nil, 0); end; otherwise: Error(cge1); end; {case} {restore data bank reg} if dataBank then begin GenNative(m_lda_dir, direct, bankLoc, nil, 0); GenImplied(m_pha); GenImplied(m_plb); GenImplied(m_plb); end; {if} {get rid of the stack frame space} if size <> 0 then GenImplied(m_pld); if size = 2 then GenImplied(m_ply) else if size <> 0 then begin GenImplied(m_tsc); GenImplied(m_clc); GenNative(m_adc_imm, immediate, size, nil, 0); GenImplied(m_tcs); end; {if} {put return value in correct place} case op^.optype of cgByte,cgUByte,cgWord,cgUWord: begin if size <> 2 then GenImplied(m_tya); if toolParms then {save value on stack for tools} GenNative(m_sta_s, direct, returnSize+1, nil, 0); end; cgLong,cgULong,cgReal,cgDouble,cgComp,cgExtended: begin GenImplied(m_tya); if toolParms then begin {save value on stack for tools} GenNative(m_sta_s, direct, returnSize+1, nil, 0); GenImplied(m_txa); GenNative(m_sta_s, direct, returnSize+3, nil, 0); end; {if} end; cgVoid: ; otherwise: Error(cge1); end; {case} {return to the caller} GenImplied(m_rtl); end; {GenRet} procedure GenSbfCbf (op: icptr); { Generate code for a pc_sbf or pc_cbf } begin {GenSbfCbf} gLong.preference := onStack; GenTree(op^.left); GenNative(m_pea, immediate, op^.r, nil, 0); GenNative(m_pea, immediate, op^.q, nil, 0); if op^.optype in [cgLong,cgULong] then begin gLong.preference := onStack; GenTree(op^.right); end {if} else begin GenNative(m_pea, immediate, 0, nil, 0); GenTree(op^.right); GenImplied(m_pha); end; {else} if op^.opcode = pc_sbf then GenCall(74) else begin GenCall(75); if not (op^.optype in [cgLong,cgULong]) then begin GenImplied(m_pla); GenImplied(m_plx); end; {if} end; {else} end; {GenSbfCbf} procedure GenSbi (op: icptr); { Generate code for a pc_sbi } begin {GenSbi} if Complex(op^.left) or Complex(op^.right) then begin GenTree(op^.right); if Complex(op^.left) then begin GenImplied(m_pha); GenTree(op^.left); GenImplied(m_sec); GenNative(m_sbc_s, direct, 1, nil, 0); GenImplied(m_plx); end {if} else begin GenNative(m_eor_imm, immediate, $FFFF, nil, 0); GenImplied(m_sec); OperA(m_adc_imm, op^.left); end; {else} end {if} else begin GenTree(op^.left); GenImplied(m_sec); OperA(m_sbc_imm, op^.right); end; {else} end; {GenSbi} procedure GenStk (op: icptr); { Generate code for a pc_stk } var lab1: integer; {branch point} begin {GenStk} glong.preference := onStack; {generate the operand} GenTree(op^.left); if op^.optype in {do the stk} [cgByte, cgUByte, cgWord, cgUWord] then GenImplied(m_pha); end; {GenStk} procedure GenShlShrUsr (op: icptr); { Generate code for a pc_shl, pc_shr or pc_usr } var i,op1,op2,num: integer; {temp variables} begin {GenShlShrUsr} {get the standard native operations} if op^.opcode = pc_shl then begin op1 := m_asl_a; op2 := m_lsr_a; end {if} else begin op1 := m_lsr_a; op2 := m_asl_a; end; {else} {take short cuts if they are legal} if (op^.right^.opcode = pc_ldc) and (op^.opcode <> pc_shr) then begin num := op^.right^.q; if (num > 16) or (num < -16) then GenNative(m_lda_imm, immediate, 0, nil, 0) else if num > 0 then begin GenTree(op^.left); if num >= 8 then begin GenImplied(m_xba); if op1 = m_lsr_a then i := $00FF else i := $FF00; GenNative(m_and_imm, immediate, i, nil, 0); num := num-8; end; {if} for i := 1 to num do GenImplied(op1); end {else if} else if num < 0 then begin GenTree(op^.left); if num <= -8 then begin GenImplied(m_xba); if op2 = m_lsr_a then i := $00FF else i := $FF00; GenNative(m_and_imm, immediate, i, nil, 0); num := num+8; end; {if} for i := 1 to -num do GenImplied(op2); end {else if} else GenTree(op^.left); end {if} else begin GenTree(op^.left); if Complex(op^.right) then begin GenImplied(m_pha); GenTree(op^.right); GenImplied(m_tax); GenImplied(m_pla); end {if} else LoadX(op^.right); if op^.opcode = pc_shl then GenCall(23) else if op^.opcode = pc_shr then GenCall(24) else {if op^.opcode = pc_usr then} GenCall(41); end; {else} end; {GenShlShrUsr} procedure GenTl1 (op: icptr); { Generate code for a pc_tl1 } var lLong: longType; {used to reserve gLong} tp: baseTypeEnum; {operand type} begin {GenTl1} if op^.r in [2,4] then begin GenImplied(m_pha); if op^.r = 4 then GenImplied(m_pha); end; {if} lLong := gLong; GenTree(op^.left); gLong := lLong; GenNative(m_ldx_imm, immediate, op^.q, nil, 0); GenNative(m_jsl, longAbs, 0, pointer(op^.lval), toolCall); if smallMemoryModel then GenNative(m_sta_abs, absolute, 0, @'~TOOLERROR', 0) else GenNative(m_sta_long, longAbs, 0, @'~TOOLERROR', 0); if op^.r in [2,4] then begin if op^.r = 2 then begin GenImplied(m_pla); tp := cgWord; end {if} else begin gLong.where := onStack; tp := cgLong; end; {else} end; {if} end; {GenTl1} procedure GenTri (op: icptr); { Generate code for a pc_tri } var lab1,lab2,lab3: integer; {label for branches} begin {GenTri} lab1 := GenLabel; lab2 := GenLabel; lab3 := GenLabel; GenTree(op^.left); if op^.left^.opcode in [pc_and,pc_ior,pc_cui,pc_cup,pc_lor,pc_lnd,pc_ldl,pc_lil,pc_lld, pc_lli,pc_gil,pc_gli,pc_gdl,pc_gld] then GenImplied(m_tax); GenNative(m_beq, relative, lab1, nil, 0); GenNative(m_brl, longrelative, lab2, nil, 0); GenLab(lab1); gLong.preference := onStack; GenTree(op^.right^.right); GenNative(m_brl, longrelative, lab3, nil, 0); GenLab(lab2); gLong.preference := onStack; GenTree(op^.right^.left); GenLab(lab3); gLong.where := onStack; end; {GenTri} procedure GenXjp (op: icptr); { Generate code for a pc_xjp } var lab1,lab2: integer; q: integer; begin {GenXjp} q := op^.q; GenTree(op^.left); GenNative(m_cmp_imm, immediate, q, nil, 0); lab1 := GenLabel; GenNative(m_bcc, relative, lab1, nil, 0); GenNative(m_lda_imm, immediate, q, nil, 0); GenLab(lab1); GenImplied(m_asl_a); GenImplied(m_tax); lab1 := GenLabel; GenNative(m_lda_longx, longAbs, lab1, nil, 0); GenImplied(m_pha); GenImplied(m_rts); GenLab(lab1); end; {GenXjp} procedure DirEnp; { Generate code for a dc_enp } begin {DirEnp} GenImplied(d_end); EndSeg; InitLabels; end; {DirEnp} procedure DirStr (op: icptr); { Generate code for a dc_str } begin {DirStr} skipLoad := false; InitNative; Header(op^.lab, op^.r, op^.q); end; {DirStr} procedure DirSym (op: icptr); { Generate code for a dc_sym } begin {DirSym} if debugFlag then GenNative(d_sym, special, op^.q, pointer(op^.lab), 0); end; {DirSym} begin {GenTree} {write('GEN: '); WriteCode(op); {debug} Spin; case op^.opcode of dc_cns: GenNative(d_cns, gnrConstant, op^.q, pointer(op), 0); dc_dst: GenNative(d_lab, gnrSpace, op^.q, nil, 0); dc_enp: DirEnp; dc_lab: GenLab(op^.q); dc_loc,dc_prm: ; dc_glb: GenNative(d_lab, gnrLabel, op^.r, op^.lab, isPrivate*op^.q); dc_pin: GenNative(d_pin, special, 0, nil, 0); dc_str: DirStr(op); dc_sym: DirSym(op); pc_add: GenNative(d_add, genaddress, op^.q, nil, 0); pc_adi: GenAdi(op); pc_adl,pc_sbl: GenAdlSbl(op, nil); pc_adr,pc_dvr,pc_mpr,pc_sbr: GenRealBinOp(op); pc_and,pc_bnd,pc_bor,pc_bxr,pc_ior: GenLogic(op); pc_blr,pc_blx,pc_bal,pc_dvl,pc_mdl,pc_mpl,pc_sll,pc_slr,pc_udl,pc_ulm, pc_uml,pc_vsr: GenBinLong(op); pc_bnl,pc_ngl: GenUnaryLong(op); pc_bno: GenBno(op); pc_bnt,pc_ngi,pc_not: GenBntNgiNot(op); pc_cnv: GenCnv(op); pc_cui: GenCui(op); pc_cup: GenCup(op); pc_dec,pc_inc: GenIncDec(op, nil); pc_dvi,pc_mod,pc_udi,pc_uim: GenDviMod(op); pc_ent: GenEnt; pc_equ,pc_neq: GenEquNeq(op, op^.opcode, 0); pc_fjp,pc_tjp: GenFjpTjp(op); pc_geq,pc_grt,pc_leq,pc_les: GenCmp(op, op^.opcode, 0); pc_gil,pc_gli,pc_gdl,pc_gld: GenGilGliGdlGld(op); pc_iil,pc_ili,pc_idl,pc_ild: GenIilIliIdlIld(op); pc_ind: GenInd(op); pc_ixa: GenIxa(op); pc_lao,pc_lad: GenLaoLad(op); pc_lbf,pc_lbu: GenLbfLbu(op); pc_lca: GenLca(op); pc_lda: GenLda(op); pc_ldc: GenLdc(op); pc_ldo: GenLdo(op); pc_lil,pc_lli,pc_ldl,pc_lld: GenLilLliLdlLld(op); pc_lnm: GenLnm(op); pc_lod: GenLod(op); pc_lor,pc_lnd: GenLorLnd(op); pc_mov: GenMov(op, true); pc_mpi,pc_umi: GenMpi(op); pc_nam: GenNam(op); pc_nat: GenNat(op); pc_ngr: GenNgr(op); pc_nop: ; pc_pop: GenPop(op); pc_psh: GenPsh(op); pc_ret: GenRet(op); pc_sbf,pc_cbf: GenSbfCbf(op); pc_sbi: GenSbi(op); pc_shl,pc_shr,pc_usr: GenShlShrUsr(op); pc_stk: GenStk(op); pc_sro,pc_cpo: GenSroCpo(op); pc_sto,pc_cpi: GenStoCpi(op); pc_str,pc_cop: GenStrCop(op); pc_tl1: GenTl1(op); pc_tri: GenTri(op); pc_ujp: GenNative(m_brl, longrelative, op^.q, nil, 0); pc_xjp: GenXjp(op); otherwise: Error(cge1); end; {case} end; {GenTree} {---------------------------------------------------------------} procedure Gen {blk: blockPtr}; { Generates native code for a list of blocks } { } { parameters: } { blk - first of the list of blocks } const locSize = 4; {variables <= this size allocated first} var bk: blockPtr; {used to trace block lists} minSize: integer; {location for the next local label} op: icptr; {used to trace code lists} procedure DirLoc1 (op: icptr); { allocates stack frame locations for small dc_loc } begin {DirLoc1} if op^.q <= locSize then begin if op^.r < maxLocalLabel then begin localLabel[op^.r] := minSize; minSize := minSize + op^.q; end {if} else Error(cge2); end; {if} end; {DirLoc1} procedure DirLoc2 (op: icptr); { allocates stack frame locations for large dc_loc } begin {DirLoc2} if op^.q > locSize then begin if op^.r < maxLocalLabel then begin localLabel[op^.r] := minSize; minSize := minSize + op^.q; end {if} else Error(cge2); end; {if} end; {DirLoc2} procedure DirPrm (op: icptr); { allocates stack frame locations for parameters } begin {DirPrm} if op^.s < maxLocalLabel then localLabel[op^.s] := localSize + returnSize + 1 + op^.r else Error(cge2); end; {DirPrm} procedure Scan (op: icptr); { scans the code stream for instructions that effect the } { size of the stack frame } { } { parameters: } { op - scan this opcode and its children } var opcode: pcodes; {op^.opcode} size: integer; {function return value size} begin {Scan} if op^.left <> nil then Scan(op^.left); if op^.right <> nil then Scan(op^.right); opcode := op^.opcode; if opcode = dc_loc then localSize := localSize + op^.q else if opcode = dc_prm then parameterSize := parameterSize + op^.q else if opcode = pc_ret then begin case op^.optype of otherwise: size := 0; cgByte,cgUByte,cgWord,cgUWord: size := cgWordSize; cgReal: size := cgRealSize; cgDouble: size := cgDoubleSize; cgComp: size := cgCompSize; cgExtended: size := cgExtendedSize; cgLong,cgULong: size := cgLongSize; end; {case} funLoc := 1; if dworkLoc <> 0 then dworkLoc := dworkLoc + size; minSize := minSize + size; localSize := localSize + size; end {else if} else if opcode in [pc_les,pc_leq,pc_grt,pc_geq,pc_sto,pc_cpi,pc_ind,pc_lor,pc_lnd, pc_ili,pc_iil,pc_idl,pc_ild,pc_ixa] then begin if dworkLoc = 0 then begin dworkLoc := minSize; minSize := minSize + 4; localSize := localSize + 4; end; {if} end; {else if} end; {Scan} begin {Gen} bk := blk; {determine the size of the stack frame} localSize := 0; parameterSize := 0; funLoc := 0; dworkLoc := 0; minSize := 1; while bk <> nil do begin op := bk^.code; while op <> nil do begin Scan(op); op := op^.next; end; {while} bk := bk^.next; end; {while} if saveStack or checkStack or strictVararg then begin stackLoc := minSize; minSize := minSize + 2; localSize := localSize + 2; end; {if} if dataBank then begin bankLoc := minSize; minSize := minSize + 2; localSize := localSize + 2; end; {if} bk := blk; {allocate locations for the values} while bk <> nil do begin op := bk^.code; while op <> nil do begin if op^.opcode = dc_loc then DirLoc1(op) else if op^.opcode = dc_prm then DirPrm(op); op := op^.next; end; {while} bk := bk^.next; end; {while} bk := blk; while bk <> nil do begin op := bk^.code; while op <> nil do begin if op^.opcode = dc_loc then DirLoc2(op); op := op^.next; end; {while} bk := bk^.next; end; {while} while blk <> nil do begin {generate code for the block} op := blk^.code; while op <> nil do begin GenTree(op); op := op^.next; end; {while} blk := blk^.next; end; {while} end; {Gen} function LabelToDisp {lab: integer): integer}; { convert a local label number to a stack frame displacement } { } { parameters: } { lab - label number } begin {LabelToDisp} if lab = 0 then LabelToDisp := funLoc else LabelToDisp := localLabel[lab]; end; {LabelToDisp} end. \ No newline at end of file diff --git a/Header.pas b/Header.pas new file mode 100755 index 0000000..bc54633 --- /dev/null +++ b/Header.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Header } { } { Handles saving and reading precompiled headers. } { } {---------------------------------------------------------------} unit Header; interface {$LibPrefix '0/obj/'} uses CCommon, MM, Scanner, Symbol, CGI; {$segment 'scanner'} var inhibitHeader: boolean; {should .sym includes be blocked?} procedure EndInclude (chPtr: ptr); { Saves symbols created by the include file } { } { Parameters: } { chPtr - chPtr when the file returned } { } { Notes: } { 1. Call this subroutine right after processing an } { include file. } { 2. Declared externally in Symbol.pas } procedure FlagPragmas (pragma: pragmas); { record the effects of a pragma } { } { parameters: } { pragma - pragma to record } { } { Notes: } { 1. Defined as extern in Scanner.pas } { 2. For the purposes of this unit, the segment statement is } { treated as a pragma. } procedure InitHeader (var fName: gsosOutString); { look for a header file, reading it if it exists } { } { parameters: } { fName - source file name (var for efficiency) } procedure TermHeader; { Stop processing the header file } { } { Note: This is called when the first code-generating } { subroutine is found, and again when the compile ends. It } { closes any open symbol file, and should take no action if } { called twice. } procedure StartInclude (name: gsosOutStringPtr); { Marks the start of an include file } { } { Notes: } { 1. Call this subroutine right after opening an include } { file. } { 2. Defined externally in Scanner.pas } {---------------------------------------------------------------} implementation const symFiletype = $5E; {symbol file type} symAuxtype = $008008; {file buffer} {-----------} bufSize = 1024; {size of output buffer} type closeOSDCB = record pcount: integer; refNum: integer; end; createOSDCB = record pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; dataEOF: longint; resourceEOF: longint; end; destroyOSDCB = record pcount: integer; pathName: gsosInStringPtr; end; getFileInfoOSDCB = record pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; getMarkOSDCB = record pcount: integer; refNum: integer; displacement: longint; end; openOSDCB = record pcount: integer; refNum: integer; pathName: gsosInStringPtr; requestAccess: integer; resourceNumber: integer; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; readWriteOSDCB = record pcount: integer; refNum: integer; dataBuffer: ptr; requestCount: longint; transferCount: longint; cachePriority: integer; end; setMarkOSDCB = record pcount: integer; refNum: integer; base: integer; displacement: longint; end; {file buffer} {-----------} bufferType = array[0..bufSize] of byte; {output buffer} var codeStarted: boolean; {has code generation started?} includeLevel: 0..maxint; {nexted include level} includeMark: boolean; {has the mark field been written?} savePragmas: set of pragmas; {pragmas to record} saveSource: boolean; {save source streams?} symChPtr: ptr; {chPtr at start of current source sequence} symEndPtr: ptr; {points to first byte past end of file} symMark: longint; {start of current block} symName: gsosOutString; {symbol file name} symStartPtr: ptr; {first byte in the symbol file} symPtr: ptr; {next byte in the symbol file} symRefnum: integer; {symName reference number} tokenMark: longint; {start of last token list} {file buffer} {-----------} buffer: ^bufferType; {output buffer} bufPtr: ^byte; {next available byte} bufLen: 0..bufSize; {bytes left in buffer} {---------------------------------------------------------------} procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B); procedure CloseGS (var parms: closeOSDCB); prodos ($2014); procedure CreateGS (var parms: createOSDCB); prodos ($2001); procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002); procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006); procedure GetMarkGS (var parms: getMarkOSDCB); prodos ($2017); procedure OpenGS (var parms: openOSDCB); prodos ($2010); procedure SetEOFGS (var parms: setMarkOSDCB); prodos ($2018); procedure SetMarkGS (var parms: setMarkOSDCB); prodos ($2016); procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013); {---------------------------------------------------------------} procedure DestroySymbolFile; { Delete any existing symbol file } var dsRec: destroyOSDCB; {DestroyGS record} giRec: getFileInfoOSDCB; {GetFileInfoGS record} begin {DestroySymbolFile} giRec.pCount := 4; giRec.pathname := @symName.theString; GetFileInfoGS(giRec); if (giRec.filetype = symFiletype) and (giRec.auxtype = symAuxtype) then begin dsRec.pCount := 1; dsRec.pathname := @symName.theString; DestroyGS(dsRec); end; {if} end; {DestroySymbolFile} procedure Purge; { Purge the output buffer } var clRec: closeOSDCB; {CloseGS record} wrRec: readWriteOSDCB; {WriteGS record} begin {Purge} wrRec.pcount := 4; wrRec.refnum := symRefnum; wrRec.dataBuffer := pointer(buffer); wrRec.requestCount := (bufSize - bufLen); WriteGS(wrRec); if ToolError <> 0 then begin clRec.pCount := 1; clRec.refnum := symRefnum; CloseGS(clRec); DestroySymbolFile; saveSource := false; end; {if} bufLen := bufSize; bufPtr := pointer(buffer); end; {Purge} procedure CloseSymbols; { Close the symbol file } var clRec: closeOSDCB; {CloseGS record} begin {CloseSymbols} Purge; clRec.pCount := 1; clRec.refnum := symRefnum; CloseGS(clRec); if numErrors <> 0 then DestroySymbolFile; end; {CloseSymbols} function ReadDouble: double; { Read a double precision real from the symbol file } { } { Returns: value read } type doubleptr = ^double; begin {ReadDouble} ReadDouble := doubleptr(symPtr)^; symPtr := pointer(ord4(symPtr)+8); end; {ReadDouble} function ReadLong: longint; { Read a long word from the symbol file } { } { Returns: long word read } type longptr = ^longint; begin {ReadLong} ReadLong := longptr(symPtr)^; symPtr := pointer(ord4(symPtr)+4); end; {ReadLong} function ReadLongString: longStringPtr; { Read a long string from the symbol file } { } { Returns: string read } var len: 0..maxint; {string buffer length} sp1, sp2: longStringPtr; {work pointers} begin {ReadLongString} sp1 := longStringPtr(symPtr); len := sp1^.length + 2; symPtr := pointer(ord4(symPtr) + len); sp2 := pointer(GMalloc(len)); BlockMove(sp1, sp2, len); ReadLongString := sp2; end; {ReadLongString} function ReadString: stringPtr; { Read a string from the symbol file } { } { Returns: string read } var len: 0..255; {string buffer length} sp1, sp2: stringPtr; {work pointers} begin {ReadString} sp1 := stringptr(symPtr); len := length(sp1^) + 1; symPtr := pointer(ord4(symPtr) + len); sp2 := pointer(GMalloc(len)); BlockMove(sp1, sp2, len); ReadString := sp2; end; {ReadString} function ReadByte: integer; { Read a byte from the symbol file } { } { Returns: byte read } type intptr = ^integer; begin {ReadByte} ReadByte := (intptr(symPtr)^) & $00FF; symPtr := pointer(ord4(symPtr)+1); end; {ReadByte} function ReadWord: integer; { Read a word from the symbol file } { } { Returns: word read } type intptr = ^integer; begin {ReadWord} ReadWord := intptr(symPtr)^; symPtr := pointer(ord4(symPtr)+2); end; {ReadWord} procedure ReadChars (var p1, p2: ptr); { Read a character stream from the file } { } { parameters: } { p1 - (output) pointer to first char in stream } { p2 - (output) points one past last char in stream } var len: integer; {length of the stream} begin {ReadChars} len := ReadWord; p1 := pointer(GMalloc(len)); p2 := pointer(ord4(p1) + len); BlockMove(symPtr, p1, len); symPtr := pointer(ord4(symPtr) + len); end; {ReadChars} procedure WriteDouble (d: double); { Write a double constant to the symbol file } { } { parameters: } { d - constant to write } var dPtr: ^double; {work pointer} begin {WriteDouble} if bufLen < 8 then Purge; dPtr := pointer(bufPtr); dPtr^ := d; bufPtr := pointer(ord4(bufPtr) + 8); bufLen := bufLen - 8; end; {WriteDouble} procedure WriteLong (i: longint); { Write a long word to the symbol file } { } { parameters: } { i - long word to write } var lPtr: ^longint; {work pointer} begin {WriteLong} if bufLen < 4 then Purge; lPtr := pointer(bufPtr); lPtr^ := i; bufPtr := pointer(ord4(bufPtr) + 4); bufLen := bufLen - 4; end; {WriteLong} procedure WriteByte (i: integer); { Write a byte to the symbol file } { } { parameters: } { i - byte to write } var iPtr: ^byte; {work pointer} begin {WriteByte} if bufLen = 0 then Purge; iPtr := pointer(bufPtr); iPtr^ := i; bufPtr := pointer(ord4(bufPtr) + 1); bufLen := bufLen - 1; end; {WriteByte} procedure WriteWord (i: integer); { Write a word to the symbol file } { } { parameters: } { i - word to write } var iPtr: ^integer; {work pointer} begin {WriteWord} if bufLen < 2 then Purge; iPtr := pointer(bufPtr); iPtr^ := i; bufPtr := pointer(ord4(bufPtr) + 2); bufLen := bufLen - 2; end; {WriteWord} procedure WriteLongString (s: longStringPtr); { Write a long string to the symbol file } { } { parameters: } { s - pointer to the string to write } var i: 0..maxint; {loop/index variables} len: 0..maxint; {string length} wrRec: readWriteOSDCB; {WriteGS record} begin {WriteLongString} len := s^.length; if bufLen < len+2 then Purge; if bufLen < len+2 then begin wrRec.pcount := 4; wrRec.refnum := symRefnum; wrRec.dataBuffer := pointer(s); wrRec.requestCount := s^.length + 2; WriteGS(wrRec); if ToolError <> 0 then begin CloseSymbols; DestroySymbolFile; saveSource := false; end; {if} end {if} else begin WriteWord(len); for i := 1 to len do begin bufPtr^ := ord(s^.str[i]); bufPtr := pointer(ord4(bufPtr) + 1); end; {for} bufLen := bufLen - len; end; {else} end; {WriteLongString} procedure WriteChars (p1, p2: ptr); { Write a stream of chars as a longString } { } { parameters: } { p1 - points to the first char to write } { p2 - points to the byte following the last char } var i: 0..maxint; {loop/index variables} len: 0..maxint; {char length} wrRec: readWriteOSDCB; {WriteGS record} begin {WriteChars} len := ord(ord4(p2) - ord4(p1)); WriteWord(len); if bufLen < len then Purge; if bufLen < len then begin if saveSource then begin wrRec.pcount := 4; wrRec.refnum := symRefnum; wrRec.dataBuffer := pointer(p1); wrRec.requestCount := ord4(p2) - ord4(p1); WriteGS(wrRec); if ToolError <> 0 then begin CloseSymbols; DestroySymbolFile; saveSource := false; end; {if} end; {if} end {if} else begin for i := 1 to len do begin bufPtr^ := p1^; bufPtr := pointer(ord4(bufPtr)+1); p1 := pointer(ord4(p1)+1); end; {for} bufLen := bufLen - len; end; {else} end; {WriteChars} procedure WriteString (s: stringPtr); { Write a string to the symbol file } { } { parameters: } { s - pointer to the string to write } var i: 0..255; {loop/index variable} len: 0..255; {length of the string} begin {WriteString} len := length(s^); if bufLen < len+1 then Purge; for i := 0 to len do begin bufPtr^ := ord(s^[i]); bufPtr := pointer(ord4(bufPtr)+1); end; {for} bufLen := bufLen - (len + 1); end; {WriteString} procedure MarkBlock; { Mark the length of the current block } var l: longint; {block length} smRec: setMarkOSDCB; {SetMarkGS record} gmRec: getMarkOSDCB; {GetMarkGS record} wrRec: readWriteOSDCB; {WriteGS record} begin {MarkBlock} Purge; {purge the buffer} gmRec.pCount := 2; {get the current EOF} gmRec.refnum := symRefnum; GetMarkGS(gmRec); if ToolError = 0 then begin smRec.pcount := 3; {set the mark to the block length field} smRec.refnum := symRefnum; smRec.base := 0; smRec.displacement := symMark; SetMarkGS(smRec); if ToolError = 0 then begin l := gmRec.displacement - smRec.displacement - 4; wrRec.pcount := 4; wrRec.refnum := symRefnum; wrRec.dataBuffer := @l; wrRec.requestCount := 4; WriteGS(wrRec); if ToolError <> 0 then begin CloseSymbols; DestroySymbolFile; saveSource := false; end; {if} smRec.displacement := gmRec.displacement; SetMarkGS(smRec); end; {if} end; {if} if ToolError <> 0 then begin {for errors, delete the symbol file} CloseSymbols; DestroySymbolFile; saveSource := false; end; {if} end; {MarkBlock} function GetMark: longint; { Find the current file mark } { } { Returns: file mark } var gmRec: getMarkOSDCB; {GetMarkGS record} begin {GetMark} gmRec.pCount := 2; gmRec.refnum := symRefnum; GetMarkGS(gmRec); GetMark := gmRec.displacement + (bufSize - bufLen); if ToolError <> 0 then begin CloseSymbols; DestroySymbolFile; saveSource := false; end; {else} end; {GetMark} procedure SetMark; { Mark the start of a block } begin {SetMark} symMark := GetMark; WriteLong(0); end; {SetMark} {---------------------------------------------------------------} procedure EndInclude {chPtr: ptr}; { Saves symbols created by the include file } { } { Parameters: } { chPtr - chPtr when the file returned } { } { Notes: } { 1. Call this subroutine right after processing an } { include file. } { 2. Declared externally in Scanner.pas } procedure SaveMacroTable; { Save macros to the symbol file } procedure SaveMacros; { Write the macros to the symbol file } var i: 0..hashSize; {loop/index variable} mp: macroRecordPtr; {used to trace macro lists} tp: tokenListRecordPtr; {used to trace token lists} procedure WriteToken (var token: tokenType); { Write a token in the header file } { } { parameters: } { token - token to write } begin {WriteToken} WriteByte(ord(token.kind)); WriteByte(ord(token.class)); if token.numstring = nil then WriteByte(0) else begin WriteByte(1); WriteString(token.numstring); end; {else} case token.class of identifier: WriteString(token.name); intConstant: WriteWord(token.ival); longConstant: WriteLong(token.lval); doubleConstant: WriteDouble(token.rval); stringConstant: begin WriteLongString(token.sval); WriteByte(ord(token.ispstring)); end; macroParameter: WriteWord(token.pnum); otherwise: ; end; {case} end; {WriteToken} begin {SaveMacros} for i := 0 to hashSize do begin {loop over hash buckets} mp := macros^[i]; {loop over macro records in hash bucket} while mp <> nil do begin if not mp^.saved then begin mp^.saved := true; {mark this one as saved} WriteString(mp^.name); {write the macroRecord} WriteByte(mp^.parameters); WriteByte(ord(mp^.readOnly)); WriteByte(mp^.algorithm); tp := mp^.tokens; {loop over token list} while tp <> nil do begin WriteByte(1); {write tokenListRecord} WriteLongString(tp^.tokenString); WriteToken(tp^.token); WriteByte(ord(tp^.expandEnabled)); WriteChars(tp^.tokenStart, tp^.tokenEnd); tp := tp^.next; end; {while} WriteByte(0); {mark end of token list} end; {if} mp := mp^.next; end; {while} end; {for} end; {SaveMacros} begin {SaveMacroTable} SetMark; {set the macro table length mark} if saveSource then {write the macro table} SaveMacros; if saveSource then {mark the length of the table} MarkBlock; end; {SaveMacroTable} procedure SavePragmaEffects; { Save the variables effected by any pragmas encountered } var count: 0..maxint; {number of path names} i: 1..10; {loop/index variable} p: pragmas; {loop variable} pp: pathRecordPtr; {used to trace pathname list} begin {SavePragmaEffects} SetMark; if saveSource then for p := succ(p_startofenum) to pred(p_endofenum) do if p in savePragmas then if saveSource then begin WriteByte(ord(p)); case p of p_cda: begin WriteString(@menuLine); WriteString(openName); WriteString(closeName); end; p_cdev: WriteString(openName); p_float: begin WriteWord(floatCard); WriteWord(floatSlot); end; p_keep: WriteLongString(@outFileGS.theString); p_line: begin WriteWord(lineNumber); WriteLongString(@sourceFileGS.theString); end; p_nda: begin WriteString(openName); WriteString(closeName); WriteString(actionName); WriteString(initName); WriteWord(refreshPeriod); WriteWord(eventMask); WriteString(@menuLine); end; p_nba: WriteString(openName); p_xcmd: WriteString(openName); p_debug: WriteByte(ord(rangeCheck) | (ord(debugFlag) << 1) | (ord(profileFlag) << 2) | (ord(traceBack) << 3) | (ord(checkStack) << 4)); p_lint: WriteWord(lint); p_memorymodel: WriteByte(ord(smallMemoryModel)); p_expand: WriteByte(ord(printMacroExpansions)); p_optimize: WriteByte(ord(peepHole) | (ord(npeepHole) << 1) | (ord(registers) << 2) | (ord(saveStack) << 3) | (ord(commonSubexpression) << 4) | (ord(loopOptimizations) << 5) | (ord(strictVararg) << 6)); p_stacksize: WriteWord(stackSize); p_toolparms: WriteByte(ord(toolParms)); p_databank: WriteByte(ord(dataBank)); p_rtl: ; p_noroot: ; p_path: begin pp := pathList; count := 0; while pp <> nil do begin count := count+1; pp := pp^.next; end; {while} WriteWord(count); pp := pathList; while pp <> nil do begin WriteString(pp^.path); pp := pp^.next; end; {while} end; {p_path} p_ignore: WriteByte(ord(skipIllegalTokens) + (ord(slashSlashComments) << 3)); p_segment: begin for i := 1 to 10 do begin WriteByte(defaultSegment[i]); WriteByte(currentSegment[i]); end; {for} WriteWord(segmentKind); end; p_unix: WriteByte(ord(unix_1)); end; {case} end; {if} if saveSource then MarkBlock; savePragmas := []; end; {SavePragmaEffects} procedure SaveSourceStream; { Save the source stream for later compares } var wrRec: readWriteOSDCB; {WriteGS record} begin {SaveSourceStream} WriteLong(ord4(chPtr) - ord4(symChPtr)); Purge; wrRec.pcount := 4; wrRec.refnum := symRefnum; wrRec.dataBuffer := pointer(symChPtr); wrRec.requestCount := ord4(chPtr) - ord4(symChPtr); WriteGS(wrRec); symChPtr := chPtr; if ToolError <> 0 then begin CloseSymbols; DestroySymbolFile; saveSource := false; end; {if} end; {SaveSourceStream} procedure SaveSymbolTable; { Save symbols to the symbol file } procedure SaveSymbol; { Write the symbols to the symbol file } var abort: boolean; {abort due to initialized var?} efRec: setMarkOSDCB; {SetEOFGS record} i: 0..hashSize; {loop/index variable} sp: identPtr; {used to trace symbol lists} procedure WriteIdent (ip: identPtr); { write a symbol to the symbol file } { } { parameters: } { ip - pointer to symbol entry } procedure WriteType (tp: typePtr); { write a type entry to the symbol file } { } { parameters: } { tp - pointer to type entry } var ip: identPtr; {for tracing field list} procedure WriteParm (pp: parameterPtr); { write a parameter list to the symbol file } { } { parameters: } { pp - parameter pointer } begin {WriteParm} while pp <> nil do begin WriteByte(1); WriteType(pp^.parameterType); pp := pp^.next; end; {while} WriteByte(0); end; {WriteParm} begin {WriteType} if tp = bytePtr then WriteByte(2) else if tp = uBytePtr then WriteByte(3) else if tp = wordPtr then WriteByte(4) else if tp = uWordPtr then WriteByte(5) else if tp = longPtr then WriteByte(6) else if tp = uLongPtr then WriteByte(7) else if tp = realPtr then WriteByte(8) else if tp = doublePtr then WriteByte(9) else if tp = extendedPtr then WriteByte(10) else if tp = stringTypePtr then WriteByte(11) else if tp = voidPtr then WriteByte(12) else if tp = voidPtrPtr then WriteByte(13) else if tp = defaultStruct then WriteByte(14) else if tp^.saveDisp <> 0 then begin WriteByte(1); WriteLong(tp^.saveDisp); end {if} else begin WriteByte(0); tp^.saveDisp := GetMark; WriteLong(tp^.size); WriteByte(ord(tp^.isConstant)); WriteByte(ord(tp^.kind)); case tp^.kind of scalarType: WriteByte(ord(tp^.baseType)); arrayType: begin WriteLong(tp^.elements); WriteType(tp^.aType); end; pointerType: WriteType(tp^.pType); functionType: begin WriteByte((ord(tp^.varargs) << 2) | (ord(tp^.prototyped) << 1) | ord(tp^.isPascal)); WriteWord(tp^.toolnum); WriteLong(tp^.dispatcher); WriteType(tp^.fType); WriteParm(tp^.parameterList); end; enumConst: WriteWord(tp^.eval); definedType: WriteType(tp^.dType); structType, unionType: begin ip := tp^.fieldList; while ip <> nil do begin WriteByte(1); WriteIdent(ip); ip := ip^.next; end; {while} WriteByte(0); end; otherwise: ; end; {case} end; {else} end; {WriteType} begin {WriteIdent} WriteString(ip^.name); WriteType(ip^.itype); if (ip^.disp = 0) and (ip^.bitDisp = 0) and (ip^.bitSize = 0) then WriteByte(0) else if (ip^.bitSize = 0) and (ip^.bitDisp = 0) then begin if ip^.disp < maxint then begin WriteByte(1); WriteWord(ord(ip^.disp)); end {if} else begin WriteByte(2); WriteLong(ip^.disp); end; {else} end {else if} else begin WriteByte(3); WriteLong(ip^.disp); WriteByte(ip^.bitDisp); WriteByte(ip^.bitSize); end; {else} if ip^.iPtr <> nil then abort := true; WriteByte(ord(ip^.state)); WriteByte(ord(ip^.isForwardDeclared)); WriteByte(ord(ip^.class)); WriteByte(ord(ip^.storage)); end; {WriteIdent} begin {SaveSymbol} abort := false; {no reason to abort, yet} for i := 0 to hashSize2 do begin {loop over hash buckets} sp := globalTable^.buckets[i]; {loop over symbol records in hash bucket} while sp <> nil do begin if not sp^.saved then begin sp^.saved := true; {mark this one as saved} WriteWord(i); {save the symbol} WriteIdent(sp); end; {if} sp := sp^.next; end; {while} end; {for} if abort then begin Purge; efRec.pcount := 3; efRec.refnum := symRefnum; efRec.base := 0; efRec.displacement := tokenMark; SetEOFGS(efRec); if ToolError <> 0 then begin CloseSymbols; DestroySymbolFile; end; {if} saveSource := false; end; {if} end; {SaveSymbol} begin {SaveSymbolTable} SetMark; {set the symbol table length mark} if saveSource then {write the symbol table} if globalTable <> nil then SaveSymbol; if saveSource then {mark the length of the table} MarkBlock; end; {SaveSymbolTable} begin {EndInclude} if not ignoreSymbols then begin includeLevel := includeLevel-1; if includeLevel = 0 then if saveSource then begin MarkBlock; {set the include name mark} SaveSourceStream; {save the source stream} SaveMacroTable; {save the macro table} SaveSymbolTable; {save the symbol table} SavePragmaEffects; {save the effects of pragmas} tokenMark := GetMark; {record mark for early exit} includeMark := false; {no include mark, yet} end; {if} end; {if} end; {EndInclude} procedure FlagPragmas {pragma: pragmas}; { record the effects of a pragma } { } { parameters: } { pragma - pragma to record } { } { Notes: } { 1. Defined as extern in Scanner.pas } { 2. For the purposes of this unit, the segment statement } { and #line directive are treated as pragmas. } begin {FlagPragmas} savePragmas := savePragmas + [pragma]; end; {FlagPragmas} procedure InitHeader {var fName: gsosOutString}; { look for a header file, reading it if it exists } { } { parameters: } { fName - source file name (var for efficiency) } type typeDispPtr = ^typeDispRecord; {type displacement/pointer table} typeDispRecord = record next: typeDispPtr; saveDisp: longint; tPtr: typePtr; end; var done: boolean; {for loop termination test} typeDispList: typeDispPtr; {type displacement/pointer table} procedure DisposeTypeDispList; { Dispose of the type displacement list } var tp: typeDispPtr; {work pointer} begin {DisposeTypeDispList} while typeDispList <> nil do begin tp := typeDispList; typeDispList := tp^.next; dispose(tp); end; {while} end; {DisposeTypeDispList} function EndOfSymbols: boolean; { See if we're at the end of the symbol file } { } { Returns: True if at the end, else false } begin {EndOfSymbols} EndOfSymbols := ord4(symPtr) >= ord4(symEndPtr); end; {EndOfSymbols} function OpenSymbols: boolean; { open and initialize the symbol file } { } { Returns: True if successful, else false } var crRec: createOSDCB; {CreateGS record} opRec: openOSDCB; {OpenGS record} begin {OpenSymbols} OpenSymbols := false; {assume we will fail} DestroySymbolFile; {destroy any existing file} crRec.pCount := 5; {create a symbol file} crRec.pathName := @symName.theString; crRec.access := $C3; crRec.fileType := symFiletype; crRec.auxType := symAuxtype; crRec.storageType := 1; CreateGS(crRec); if ToolError = 0 then begin opRec.pCount := 3; opRec.pathname := @symName.theString; opRec.requestAccess := 3; OpenGS(opRec); if ToolError = 0 then begin symRefnum := opRec.refnum; OpenSymbols := true; WriteWord(1); tokenMark := GetMark; includeMark := false; end; {if} end; {if} end; {OpenSymbols} procedure PurgeSymbols; { Purge the symbol input file } var ffDCBGS: fastFileDCBGS; {fast file DCB} begin {PurgeSymbols} with ffDCBGS do begin {purge the file} pCount := 5; action := 7; pathName := @symName.theString; end; {with} FastFileGS(ffDCBGS); end; {PurgeSymbols} function DatesMatch: boolean; { Make sure the create/mod dates have not changed } var giRec: getFileInfoOSDCB; {GetFileInfoGS record} i: 1..maxint; {loop/index variable} len: longint; {length of names} match: boolean; {do the dates match?} begin {DatesMatch} match := true; len := ReadLong; while len > 0 do begin giRec.pCount := 7; giRec.pathname := pointer(ReadLongString); len := len - (giRec.pathname^.size + 18); GetFileInfoGS(giRec); if ToolError = 0 then begin for i := 1 to 8 do match := match and (giRec.createDateTime[i] = ReadByte); for i := 1 to 8 do match := match and (giRec.modDateTime[i] = ReadByte); end {if} else begin match := false; len := 0; end; {else} if match and progress then begin write('Including '); for i := 1 to giRec.pathname^.size do write(giRec.pathname^.theString[i]); writeln; end; {if} end; {while} DatesMatch := match; end; {DatesMatch} procedure ReadMacroTable; { Read macros from the symbol file } var bp: ^macroRecordPtr; {pointer to head of hash bucket} ep: tokenListRecordPtr; {last token record} mePtr: ptr; {end of macro table} mp: macroRecordPtr; {new macro record} tlen: integer; {length of the token name} tp: tokenListRecordPtr; {new token record} procedure ReadToken (var token: tokenType); { read a token } { } { parameters: } { token - (output) token read) } begin {ReadToken} token.kind := tokenEnum(ReadByte); token.class := tokenClass(ReadByte); if ReadByte = 0 then token.numString := nil else token.numstring := ReadString; case token.class of identifier: token.name := ReadString; intConstant: token.ival := ReadWord; longConstant: token.lval := ReadLong; doubleConstant: token.rval := ReadDouble; stringConstant: begin token.sval := ReadLongString; token.ispstring := ReadByte <> 0; end; macroParameter: token.pnum := ReadWord; otherwise: ; end; {case} end; {ReadToken} begin {ReadMacroTable} mePtr := symPtr; {read the block length} mePtr := pointer(ord4(mePtr) + ReadLong + 4); while ord4(symPtr) < ord4(mePtr) do {process the macros} begin Spin; mp := pointer(GMalloc(sizeof(macroRecord))); mp^.saved := false; mp^.name := ReadString; bp := pointer(ord4(macros) + Hash(mp^.name)); mp^.next := bp^; bp^ := mp; mp^.parameters := ReadByte; if mp^.parameters & $0080 <> 0 then mp^.parameters := mp^.parameters | $FF00; mp^.readOnly := boolean(ReadByte); mp^.algorithm := ReadByte; mp^.tokens := nil; ep := nil; while ReadByte <> 0 do begin tp := pointer(GMalloc(sizeof(tokenListRecord))); tp^.next := nil; tp^.tokenString := ReadLongString; ReadToken(tp^.token); tp^.expandEnabled := boolean(ReadByte); ReadChars(tp^.tokenStart, tp^.tokenEnd); if ep = nil then mp^.tokens := tp else ep^.next := tp; ep := tp; end; {while} end; {while} symPtr := mePtr; end; {ReadMacroTable} procedure ReadPragmas; { Read pragma effects } var i: 0..maxint; {loop/index variable} lsPtr: longStringPtr; {work pointer} p: pragmas; {kind of pragma being processed} pePtr: ptr; {end of pragma table} pp, ppe: pathRecordPtr; {used to create a path name list} sPtr: stringPtr; {work pointer} val: integer; {temp value} begin {ReadPragmas} pePtr := symPtr; {read the block length} pePtr := pointer(ord4(pePtr) + ReadLong + 4); while ord4(symPtr) < ord4(pePtr) do {process the pragmas} begin Spin; p := pragmas(ReadByte); case p of p_cda: begin isClassicDeskAcc := true; sPtr := ReadString; menuLine := sPtr^; openName := ReadString; closeName := ReadString; end; p_cdev: begin isCDev := true; openName := ReadString; end; p_float: begin floatCard := ReadWord; floatSlot := ReadWord; end; p_keep: begin liDCBGS.kFlag := 1; lsPtr := ReadLongString; outFileGS.theString.size := lsPtr^.length; for i := 1 to outFileGS.theString.size do outFileGS.theString.theString[i] := lsPtr^.str[i]; end; p_line: begin lineNumber := ReadWord; lsPtr := ReadLongString; sourceFileGS.theString.size := lsPtr^.length; for i := 1 to sourceFileGS.theString.size do sourceFileGS.theString.theString[i] := lsPtr^.str[i]; end; p_nda: begin isNewDeskAcc := true; openName := ReadString; closeName := ReadString; actionName := ReadString; initName := ReadString; refreshPeriod := ReadWord; eventMask := ReadWord; sPtr := ReadString; menuLine := sPtr^; end; p_nba: begin isNBA := true; openName := ReadString; end; p_xcmd: begin isXCMD := true; openName := ReadString; end; p_debug: begin val := ReadByte; rangeCheck := odd(val); debugFlag := odd(val >> 1); profileFlag := odd(val >> 2); traceback := odd(val >> 3); checkStack := odd(val >> 4); end; p_lint: lint := ReadWord; p_memorymodel: smallMemoryModel := boolean(ReadByte); p_expand: printMacroExpansions := boolean(ReadByte); p_optimize: begin val := ReadByte; peepHole := odd(val); npeepHole := odd(val >> 1); registers := odd(val >> 2); saveStack := odd(val >> 3); commonSubexpression := odd(val >> 4); loopOptimizations := odd(val >> 5); strictVararg := odd(val >> 6); end; p_stacksize: stackSize := ReadWord; p_toolparms: toolParms := boolean(ReadByte); p_databank: dataBank := boolean(ReadByte); p_rtl: rtl := true; p_noroot: noroot := true; p_path: begin i := ReadWord; pathList := nil; ppe := nil; while i <> 0 do begin pp := pathRecordPtr(GMalloc(sizeof(pathRecord))); pp^.path := ReadString; pp^.next := nil; if pathList = nil then pathList := pp else ppe^.next := pp; ppe := pp; i := i-1; end; {while} end; {p_path} p_ignore: begin i := ReadByte; skipIllegalTokens := odd(i); slashSlashComments := odd(i >> 3); end; p_segment: begin for i := 1 to 10 do begin defaultSegment[i] := chr(ReadByte); currentSegment[i] := chr(ReadByte); end; {for} segmentKind := ReadWord; end; p_unix: unix_1 := boolean(ReadByte); end; {case} end; {while} symPtr := pePtr; end; {ReadPragmas} procedure ReadSymbolTable; { Read symbols from the symbol file } var hashPtr: ^identPtr; {pointer to hash bucket in symbol table} sePtr: ptr; {end of symbol table} sp: identPtr; {identifier being constructed} function ReadIdent: identPtr; { Read an identifier from the file } { } { Returns: Pointer to the new identifier } var format: 0..3; {storage format} sp: identPtr; {identifier being constructed} procedure ReadType (var tp: typePtr); { read a type from the symbol file } { } { parameters: } { tp - (output) type entry } var disp: longint; {disp read from symbol file} ep: identPtr; {end of list of field names} ip: identPtr; {for tracing field list} tdisp: typeDispPtr; {used to trace, add to typeDispList} val: integer; {temp word} procedure ReadParm (var pp: parameterPtr); { read a parameter list from the symbol file } { } { parameters: } { pp - (output) parameter pointer } var ep: parameterPtr; {last parameter in list} np: parameterPtr; {new parameter} begin {ReadParm} pp := nil; ep := nil; while ReadByte = 1 do begin np := parameterPtr(GMalloc(sizeof(parameterRecord))); np^.next := nil; np^.parameter := nil; ReadType(np^.parameterType); if ep = nil then pp := np else ep^.next := np; ep := np; end; {while} end; {ReadParm} begin {ReadType} case ReadByte of 0: begin {read a new type} tp := typePtr(GMalloc(sizeof(typeRecord))); new(tdisp); tdisp^.next := typeDispList; typeDispList := tdisp; tdisp^.saveDisp := ord4(symPtr) - ord4(symStartPtr); tdisp^.tPtr := tp; tp^.size := ReadLong; tp^.saveDisp := 0; tp^.isConstant := boolean(ReadByte); tp^.kind := typeKind(ReadByte); case tp^.kind of scalarType: tp^.baseType := baseTypeEnum(ReadByte); arrayType: begin tp^.elements := ReadLong; ReadType(tp^.aType); end; pointerType: ReadType(tp^.pType); functionType: begin val := ReadByte; tp^.varargs := odd(val >> 2); tp^.prototyped := odd(val >> 1); tp^.isPascal := odd(val); tp^.toolnum := ReadWord; tp^.dispatcher := ReadLong; ReadType(tp^.fType); ReadParm(tp^.parameterList); end; enumConst: tp^.eval := ReadWord; definedType: ReadType(tp^.dType); structType, unionType: begin tp^.fieldList := nil; ep := nil; while ReadByte = 1 do begin ip := ReadIdent; if ep = nil then tp^.fieldList := ip else ep^.next := ip; ep := ip; end; {while} end; otherwise: ; end; {case} end; {case 0} 1: begin {read a type displacement} tdisp := typeDispList; disp := ReadLong; while tdisp <> nil do if tdisp^.saveDisp = disp then begin tp := tdisp^.tPtr; tdisp := nil; end {if} else tdisp := tdisp^.next; end; {case 1} 2: tp := bytePtr; 3: tp := uBytePtr; 4: tp := wordPtr; 5: tp := uWordPtr; 6: tp := longPtr; 7: tp := uLongPtr; 8: tp := realPtr; 9: tp := doublePtr; 10: tp := extendedPtr; 11: tp := stringTypePtr; 12: tp := voidPtr; 13: tp := voidPtrPtr; 14: tp := defaultStruct; end; {case} end; {ReadType} begin {ReadIdent} sp := pointer(GMalloc(sizeof(identRecord))); sp^.next := nil; sp^.saved := false; sp^.name := ReadString; ReadType(sp^.itype); format := ReadByte; if format = 0 then begin sp^.disp := 0; sp^.bitDisp := 0; sp^.bitSize := 0; end {if} else if format = 1 then begin sp^.disp := ReadWord; sp^.bitDisp := 0; sp^.bitSize := 0; end {else if} else if format = 2 then begin sp^.disp := ReadLong; sp^.bitDisp := 0; sp^.bitSize := 0; end {else if} else begin sp^.disp := ReadLong; sp^.bitDisp := ReadByte; sp^.bitSize := ReadByte; end; {else} sp^.iPtr := nil; sp^.state := stateKind(ReadByte); sp^.isForwardDeclared := boolean(ReadByte); sp^.class := tokenEnum(ReadByte); sp^.storage := storageType(ReadByte); ReadIdent := sp; end; {ReadIdent} begin {ReadSymbolTable} sePtr := symPtr; {read the block length} sePtr := pointer(ord4(sePtr) + ReadLong + 4); while ord4(symPtr) < ord4(sePtr) do {process the symbols} begin Spin; hashPtr := pointer(ord4(globalTable) + ReadWord*4); sp := ReadIdent; sp^.next := hashPtr^; hashPtr^ := sp; end; {while} symPtr := sePtr; end; {ReadSymbolTable} function OpenSymbolFile (var fName: gsosOutString): boolean; { Look for and open a symbol file } { } { parameters: } { fName - source file name (var for efficiency) } { } { Returns: True if the file was found and opened, else false } { } { Notes: As a side effect, this subroutine creates the } { pathname for the symbol file (symName). } var ffDCBGS: fastFileDCBGS; {fast file DCB} i: integer; {loop/index variable} begin {OpenSymbolFile} symName := fName; {create the symbol file name} i := symName.theString.size - 1; while not (symName.theString.theString[i] in [':', '/', '.']) do i := i-1; if symName.theString.theString[i] <> '.' then i := symName.theString.size; if i > maxPath-5 then i := maxPath-5; symName.theString.theString[i] := '.'; symName.theString.theString[i+1] := 's'; symName.theString.theString[i+2] := 'y'; symName.theString.theString[i+3] := 'm'; symName.theString.theString[i+4] := chr(0); symName.theString.size := i+3; if rebuildSymbols then begin {rebuild any existing symbol file} DestroySymbolFile; OpenSymbolFile := false; end {if} else begin with ffDCBGS do begin {read the symbol file} pCount := 14; action := 0; flags := $C000; pathName := @symName.theString; end; {with} FastFileGS(ffDCBGS); if ToolError = 0 then begin if (ffDCBGS.filetype = symFiletype) and (ffDCBGS.auxtype = symAuxtype) then OpenSymbolFile := true else begin OpenSymbolFile := false; PurgeSymbols; end; {else} symPtr := ffDCBGS.fileHandle^; symStartPtr := symPtr; symEndPtr := pointer(ord4(symPtr) + ffDCBGS.fileLength); end {if} else OpenSymbolFile := false; end; {else} end; {OpenSymbolFile} function SymbolVersion: integer; { Read the symbol file version number } { } { Returns: version number } begin {SymbolVersion} SymbolVersion := ReadWord; end; {SymbolVersion} function SourceMatches: boolean; { Make sure the token streams match up to the next include } type intPtr = ^integer; {for faster compares} var len, len2: longint; {size of stream to compare} match: boolean; {result flag} p1, p2: ptr; {work pointers} begin {SourceMatches} match := true; len := ReadLong; len2 := len; p1 := symPtr; p2 := chPtr; while len > 1 do if intPtr(p1)^ <> intPtr(p2)^ then begin match := false; len := 0; end {if} else begin len := len-2; p1 := pointer(ord4(p1)+2); p2 := pointer(ord4(p2)+2); end; {else} if len = 1 then if p1^ <> p2^ then match := false; if match then begin symPtr := pointer(ord4(symPtr)+len2); symChPtr := pointer(ord4(chPtr)+len2); while chPtr <> symChPtr do NextCh; end; {if} SourceMatches := match; end; {SourceMatches} begin {InitHeader} inhibitHeader := false; {don't block .sym files} if not ignoreSymbols then begin codeStarted := false; {code generation has not started} new(buffer); {allocate an output buffer} bufPtr := pointer(buffer); bufLen := bufSize; includeLevel := 0; {no nested includes} symChPtr := chPtr; {record initial source location} if OpenSymbolFile(fName) then begin {check for symbol file} if SymbolVersion = 1 then begin done := EndOfSymbols; {valid file found - process it} if done then PurgeSymbols; typeDispList := nil; while not done do begin if DatesMatch then begin if SourceMatches then begin ReadMacroTable; ReadSymbolTable; ReadPragmas; if EndOfSymbols then begin done := true; PurgeSymbols; end; {if} end {if} else begin PurgeSymbols; DestroySymbolFile; done := true; end; {else} end {if} else begin PurgeSymbols; DestroySymbolFile; done := true; end; {else} end; {while} DisposeTypeDispList; saveSource := false; end {if} else begin PurgeSymbols; {no file found} saveSource := true; end; {else} end {if} else saveSource := true; if saveSource then begin {start saving source} saveSource := OpenSymbols; savePragmas := []; DoDefaultsDotH; end; {if} end {if} else DoDefaultsDotH; end; {InitHeader} procedure StartInclude {name: gsosOutStringPtr}; { Marks the start of an include file } { } { Notes: } { 1. Call this subroutine right after opening an include } { file. } { 2. Defined externally in Scanner.pas } var giRec: getFileInfoOSDCB; {GetFileInfoGS record} i: 1..8; {loop/index counter} begin {StartInclude} if inhibitHeader then TermHeader; if not ignoreSymbols then begin includeLevel := includeLevel+1; if saveSource then begin if not includeMark then begin includeMark := true; SetMark; end; {if} giRec.pCount := 7; giRec.pathname := pointer(ord4(name)+2); GetFileInfoGS(giRec); WriteLongString(pointer(giRec.pathname)); for i := 1 to 8 do WriteByte(giRec.createDateTime[i]); for i := 1 to 8 do WriteByte(giRec.modDateTime[i]); end {if} else if not codeStarted then DestroySymbolFile; end; {if} end; {StartInclude} procedure TermHeader; { Stop processing the header file } { } { Note: This is called when the first code-generating } { subroutine is found, and again when the compile ends. It } { closes any open symbol file, and should take no action if } { called twice. } begin {TermHeader} if not ignoreSymbols then begin codeStarted := true; if saveSource then begin CloseSymbols; saveSource := false; dispose(buffer); end; {if} end; {if} end; {TermHeader} end. \ No newline at end of file diff --git a/Header2.pas b/Header2.pas new file mode 100755 index 0000000..bc8a566 --- /dev/null +++ b/Header2.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Header } { } { Handles saving and reading precompiled headers. } { } {---------------------------------------------------------------} unit Header; {$LibPrefix '0/obj/'} interface uses CCommon, MM, Scanner, Symbol, CGI; {$segment 'scanner'} var inhibitHeader: boolean; {should .sym includes be blocked?} procedure EndInclude (chPtr: ptr); { Saves symbols created by the include file } { } { Parameters: } { chPtr - chPtr when the file returned } { } { Notes: } { 1. Call this subroutine right after processing an } { include file. } { 2. Declared externally in Symbol.pas } procedure FlagPragmas (pragma: pragmas); { record the effects of a pragma } { } { parameters: } { pragma - pragma to record } { } { Notes: } { 1. Defined as extern in Scanner.pas } { 2. For the purposes of this unit, the segment statement is } { treated as a pragma. } procedure InitHeader (var fName: gsosOutString); { look for a header file, reading it if it exists } { } { parameters: } { fName - source file name (var for efficiency) } procedure TermHeader; { Stop processing the header file } { } { Note: This is called when the first code-generating } { subroutine is found, and again when the compile ends. It } { closes any open symbol file, and should take no action if } { called twice. } procedure StartInclude (name: gsosOutStringPtr); { Marks the start of an include file } { } { Notes: } { 1. Call this subroutine right after opening an include } { file. } { 2. Defined externally in Scanner.pas } {---------------------------------------------------------------} implementation procedure EndInclude {chPtr: ptr}; { Saves symbols created by the include file } { } { Parameters: } { chPtr - chPtr when the file returned } { } { Notes: } { 1. Call this subroutine right after processing an } { include file. } { 2. Declared externally in Symbol.pas } begin {EndInclude} end; {EndInclude} procedure FlagPragmas {pragma: pragmas}; { record the effects of a pragma } { } { parameters: } { pragma - pragma to record } { } { Notes: } { 1. Defined as extern in Scanner.pas } { 2. For the purposes of this unit, the segment statement is } { treated as a pragma. } begin {FlagPragmas} end; {FlagPragmas} procedure InitHeader {var fName: gsosOutString}; { look for a header file, reading it if it exists } { } { parameters: } { fName - source file name (var for efficiency) } begin {InitHeader} end; {InitHeader} procedure StartInclude {name: gsosOutStringPtr}; { Marks the start of an include file } { } { Notes: } { 1. Call this subroutine right after opening an include } { file. } { 2. Defined externally in Scanner.pas } begin {StartInclude} end; {StartInclude} procedure TermHeader; { Stop processing the header file } { } { Note: This is called when the first code-generating } { subroutine is found, and again when the compile ends. It } { closes any open symbol file, and should take no action if } { called twice. } begin {TermHeader} end; {TermHeader} end. \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..262e174 --- /dev/null +++ b/LICENSE @@ -0,0 +1,11 @@ +ORCA/C is released by the copyright holder under the terms of the original copyright. + +The Byte Works, Inc. grants you the right to use this source code privately, fork it, and change it. + +You may not redistribute the code in any form other than submission to this repository without the written permission of the copyright holder. + +The copyright holder decided to do things this way for two reasons: + +1. Reserve commercial distribution rights. + +2. Ensure that any contributions and updates are available from a centralized source (this GitHib repository, for now). diff --git a/MM.asm b/MM.asm new file mode 100755 index 0000000..aac8d30 --- /dev/null +++ b/MM.asm @@ -0,0 +1 @@ + mcopy mm.macros **************************************************************** * * Calloc - Allocate memory from a pool and set it to 0. * * Inputs: * bytes - number of bytes to allocate * useGlobalPool - should the memory come from the global * (or local) pool * * Outputs: * ptr - points to the first byte of the allocated memory * **************************************************************** * Calloc start ptr equ 0 pointer to reserved memory subroutine (2:bytes),4 ph2 bytes reserve the memory jsl Malloc sta ptr save the pointer to the memory stx ptr+2 lda bytes if there are an odd number of bytes then tay lsr a bcc lb1 short M zero the first byte lda #0 dey sta [ptr],Y long M lb1 tyx done if there are no more bytes beq lb4 lda #0 dey branch if the next word is the zeroth dey beq lb3 lb2 sta [ptr],Y zero full words dey dey bne lb2 lb3 sta [ptr] zero the last word lb4 return 4:ptr return the pointer end **************************************************************** * * GCalloc - Allocate and clear memory from the global pool. * * Inputs: * bytes - number of bytes to allocate * * Outputs: * ptr - points to the first byte of the allocated memory * **************************************************************** * GCalloc start ptr equ 0 pointer to reserved memory subroutine (2:bytes),4 ph2 bytes reserve the memory jsl GMalloc sta ptr save the pointer to the memory stx ptr+2 lda bytes if there are an odd number of bytes then tay lsr a bcc lb1 short M zero the first byte lda #0 dey sta [ptr],Y long M lb1 tyx done if there are no more bytes beq lb4 lda #0 dey branch if the next word is the zeroth dey beq lb3 lb2 sta [ptr],Y zero full words dey dey bne lb2 lb3 sta [ptr] zero the last word lb4 return 4:ptr return the pointer end **************************************************************** * * Malloc - Allocate memory from a pool. * * Inputs: * bytes - number of bytes to allocate * useGlobalPool - should the memory come from the global * (or local) pool * * Outputs: * ptr - points to the first byte of the allocated memory * **************************************************************** * Malloc start lda useGlobalPool jne GMalloc jmp LMalloc end \ No newline at end of file diff --git a/MM.macros b/MM.macros new file mode 100755 index 0000000..ea3fa02 --- /dev/null +++ b/MM.macros @@ -0,0 +1 @@ + MACRO &lab subroutine &parms,&work &lab anop aif c:&work,.a lclc &work &work setc 0 .a gbla &totallen gbla &worklen &worklen seta &work &totallen seta 0 aif c:&parms=0,.e lclc &len lclc &p lcla &i &i seta c:&parms .b &p setc &parms(&i) &len amid &p,2,1 aif "&len"=":",.c &len amid &p,1,2 &p amid &p,4,l:&p-3 ago .d .c &len amid &p,1,1 &p amid &p,3,l:&p-2 .d &p equ &totallen+3+&work &totallen seta &totallen+&len &i seta &i-1 aif &i,^b .e tsc sec sbc #&work tcs inc a phd tcd mend MACRO &lab return &r &lab anop lclc &len aif c:&r,.a lclc &r &r setc 0 &len setc 0 ago .h .a &len amid &r,2,1 aif "&len"=":",.b &len amid &r,1,2 &r amid &r,4,l:&r-3 ago .c .b &len amid &r,1,1 &r amid &r,3,l:&r-2 .c aif &len<>2,.d ldy &r ago .h .d aif &len<>4,.e ldx &r+2 ldy &r ago .h .e aif &len<>10,.g aif &totallen=0,.f lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .f pld tsc clc adc #&worklen+&totallen tcs phb plx ply lda &r+8 pha lda &r+6 pha lda &r+4 pha lda &r+2 pha lda &r pha phy phx plb rtl mexit .g mnote 'Not a valid return length',16 mexit .h aif &totallen=0,.i lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .i pld tsc clc adc #&worklen+&totallen tcs aif &len=0,.j tya .j rtl mend MACRO &LAB JNE &BP &LAB BEQ *+5 BRL &BP MEND MACRO &LAB LONG &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB REP #&M*32+&I*16 AIF .NOT.&M,.B LONGA ON .B AIF .NOT.&I,.C LONGI ON .C MEND MACRO &LAB PH2 &N1 LCLC &C &LAB ANOP &C AMID &N1,1,1 AIF "&C"="#",.D AIF S:LONGA=1,.A REP #%00100000 .A AIF "&C"<>"{",.B &C AMID &N1,L:&N1,1 AIF "&C"<>"}",.G &N1 AMID &N1,2,L:&N1-2 LDA (&N1) PHA AGO .E .B LDA &N1 PHA AGO .E .D &N1 AMID &N1,2,L:&N1-1 PEA &N1 AGO .F .E AIF S:LONGA=1,.F SEP #%00100000 .F MEXIT .G MNOTE "Missing closing '}'",16 MEND MACRO &LAB SHORT &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB SEP #&M*32+&I*16 AIF .NOT.&M,.B LONGA OFF .B AIF .NOT.&I,.C LONGI OFF .C MEND \ No newline at end of file diff --git a/MM.pas b/MM.pas new file mode 100755 index 0000000..99d2418 --- /dev/null +++ b/MM.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Memory Manager } { } { This memory manager provides a stack-based memory allocation } { and deallocation mechanism to allow compact symbol tables } { that can be disposed of with a single call after a function } { has been compiled. Two separate stacks, or pools, are } { available. The local pool is typically disposed of when } { the compilation of a function is complete. It is used for } { local memory allocations such as local strings and symbols. } { The global pool is used for global values like macro } { definitions and global symbols. } { } { External Variables: } { localID - userID for the local pool } { globalID - userID for the global pool } { } { External Subroutines: } { DisposeLocalPool - dump the local memory pool } { Calloc - clear and allocate memory } { GCalloc - allocate & clear memory from the global pool } { GInit - initialize a global pool } { GMalloc - allocate memory from the global pool } { LInit - initialize a local pool } { LMalloc - allocate memory from the local pool } { Malloc - allocate memory } { MMQuit - Dispose of memory allocated with private user } { IDs } { } {---------------------------------------------------------------} unit MM; {$LibPrefix '0/obj/'} interface uses CCommon; var localID,globalID: integer; {user ID's for the local & global pools} {---------------------------------------------------------------} function Calloc (bytes: integer): ptr; extern; { Allocate memory from a pool and set it to 0. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } function GCalloc (bytes: integer): ptr; extern; { Allocate and clear memory from the global pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } procedure GInit; { Initialize a global pool } function GMalloc (bytes: integer): ptr; { Allocate memory from the global pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } procedure LInit; { Initialize a local pool } function LMalloc (bytes: integer): ptr; { Allocate memory from the local pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } function Malloc (bytes: integer): ptr; extern; { Allocate memory from a pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } { } { Globals: } { useGlobalPool - should the memory come from the global } { (or local) pool } procedure MMQuit; { Dispose of memory allocated with private user IDs } {---------------------------------------------------------------} implementation const poolSize = 4096; {size of a memory pool} var globalPtr: ptr; {pointer to the next free global byte} globalSize: integer; {bytes remaining in the global pool} localPtr: ptr; {pointer to the next free local byte} localSize: integer; {bytes remaining in the local pool} {---------------------------------------------------------------} {GS memory manager} {-----------------} procedure DisposeAll (userID: integer); tool($02, $11); function NewHandle (blockSize: longint; userID, memAttributes: integer; memLocation: ptr): handle; tool($02, $09); {---------------------------------------------------------------} procedure GInit; { Initialize a global pool } var myhandle: handle; {for dereferencing the block} begin {GInit} globalID := UserID | $0200; {set the global user ID} DisposeAll(globalID); {dump any old pool areas} globalSize := poolSize; {allocate a new pool} myhandle := NewHandle(poolSize, globalID, $C010, nil); if ToolError <> 0 then TermError(5); globalPtr := myhandle^; end; {GInit} function GMalloc {bytes: integer): ptr}; { Allocate memory from the global pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } var myhandle: handle; {for dereferencing the block} begin {GMalloc} if bytes > globalSize then begin {allocate a new pool, if needed} globalSize := poolSize; myhandle := NewHandle(poolSize, globalID, $C010, nil); if ToolError <> 0 then TermError(5); globalPtr := myhandle^; end; {if} GMalloc := globalPtr; {allocate memory from the pool} globalSize := globalSize - bytes; globalPtr := pointer(ord4(globalPtr) + bytes); end; {GMalloc} procedure LInit; { Initialize a local pool } var myhandle: handle; {for dereferencing the block} begin {LInit} localID := UserID | $0400; {set the local user ID} DisposeAll(localID); {dump any old pool areas} localSize := poolSize; {allocate a new pool} myhandle := NewHandle(poolSize, localID, $C010, nil); if ToolError <> 0 then TermError(5); localPtr := myhandle^; end; {LInit} function LMalloc {bytes: integer): ptr}; { Allocate memory from the local pool. } { } { Parameters: } { bytes - number of bytes to allocate } { ptr - points to the first byte of the allocated memory } var myhandle: handle; {for dereferencing the block} begin {LMalloc} if bytes > localSize then begin {allocate a new pool, if needed} localSize := poolSize; myhandle := NewHandle(poolSize, localID, $C010, nil); if ToolError <> 0 then TermError(5); localPtr := myhandle^; end; {if} LMalloc := localPtr; {allocate memory from the pool} localSize := localSize - bytes; localPtr := pointer(ord4(localPtr) + bytes); end; {LMalloc} procedure MMQuit; { Dispose of memory allocated with private user IDs } begin {MMQuit} DisposeAll(globalID); DisposeAll(localID); end; {MMQuit} end. {$append 'mm.asm'} \ No newline at end of file diff --git a/Native.asm b/Native.asm new file mode 100755 index 0000000..46a01a5 --- /dev/null +++ b/Native.asm @@ -0,0 +1 @@ + mcopy native.macros **************************************************************** * * Remove - remove an instruction from the peephole array * * Inputs: * ns - index of element to remove * **************************************************************** * Remove start elSize equ 12 size of an element nPeepSize equ 128 size of array ns equ 4 array element lda ns,S compute the source address cmp #nPeepSize (quit if nothing to move) bge rtl asl a adc ns,S asl a asl a adc #NPEEP tax sec compute the source address sbc #elSize tay sec compute the move length sbc #(nPeepSize-1)*elSize+NPEEP eor #$FFFF mvn NPEEP,NPEEP move the array elements rtl dec nNextSpot nnextspot := nnextspot-1; lda #1 didone := true; sta didOne lda 2,S fix stack and return sta 4,S pla sta 1,S rtl end **************************************************************** * * Short - See if label lab is within short range of instruction n * * Inputs: * n - instruction number * lab - label number * **************************************************************** * Short start elSize equ 12 size of npeep array element peep_opcode equ 0 disp in nativeType of opcode peep_mode equ 2 disp in nativeType of mode peep_operand equ 4 disp in nativeType of operand peep_name equ 6 disp in nativeType of name peep_flags equ 10 disp in nativeType of flags d_lab equ 256 label op code # len equ 0 i equ 2 subroutine (2:n,2:lab),4 stz len len := 0; lda n i := n-1; dec a while i > 0 do begin dec a ldx #elSize jsl ~mul2 tax bmi lb3 lb1 lda nPeep+peep_opcode,X if npeep[i].opcode = d_lab then cmp #d_lab bne lb2 lda nPeep+peep_operand,X if npeep[i].operand = lab then begin cmp lab bne lb2 stz fn Short := len <= 126; lda len cmp #127 bge lab1 inc fn bra lab1 goto 1; lb2 anop end; lda nPeep+peep_opcode,X len := len+size[npeep[i].mode]; tay lda size,Y and #$00FF clc adc len sta len txa i := i-1; sec sbc #elSize tax bpl lb1 end; {while} lb3 stz len len := 0; lda n i := n+1; ldx #elSize jsl ~mul2 tax lda n inc a sta i lb4 lda i while i < nnextspot do begin cmp nNextSpot bge lb6 lda nPeep+peep_opcode,X if npeep[i].opcode = d_lab then cmp #d_lab bne lb5 lda nPeep+peep_operand,X if npeep[i].operand = lab then begin cmp lab bne lb5 stz fn Short := len < 128; lda len cmp #128 bge lab1 inc fn bra lab1 goto 1; lb5 anop end; lda nPeep+peep_opcode,X len := len+size[npeep[i].mode]; tay lda size,Y and #$00FF clc adc len sta len inc i i := i+1; txa clc adc #elSize tax bra lb4 end; {while} lb6 stz fn Short := false; lab1 anop 1:end; {Short} return 2:fn fn ds 2 function return value size dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'3,2,4,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'1,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,3,2,2,2,1,3,1,1,4,3,3,4' dc i1'1,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'3,2,3,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'3,2,2,2,2,2,2,2,1,3,1,1,3,3,3,4' dc i1'2,2,2,2,3,2,2,2,1,3,1,1,3,3,3,4' dc i1'0,0,1,2,0,2,0,255' end \ No newline at end of file diff --git a/Native.macros b/Native.macros new file mode 100755 index 0000000..33a7632 --- /dev/null +++ b/Native.macros @@ -0,0 +1 @@ + MACRO &lab subroutine &parms,&work &lab anop aif c:&work,.a lclc &work &work setc 0 .a gbla &totallen gbla &worklen &worklen seta &work &totallen seta 0 aif c:&parms=0,.e lclc &len lclc &p lcla &i &i seta c:&parms .b &p setc &parms(&i) &len amid &p,2,1 aif "&len"=":",.c &len amid &p,1,2 &p amid &p,4,l:&p-3 ago .d .c &len amid &p,1,1 &p amid &p,3,l:&p-2 .d &p equ &totallen+3+&work &totallen seta &totallen+&len &i seta &i-1 aif &i,^b .e tsc sec sbc #&work tcs inc a phd tcd mend MACRO &lab return &r &lab anop lclc &len aif c:&r,.a lclc &r &r setc 0 &len setc 0 ago .h .a &len amid &r,2,1 aif "&len"=":",.b &len amid &r,1,2 &r amid &r,4,l:&r-3 ago .c .b &len amid &r,1,1 &r amid &r,3,l:&r-2 .c aif &len<>2,.d ldy &r ago .h .d aif &len<>4,.e ldx &r+2 ldy &r ago .h .e aif &len<>10,.g aif &totallen=0,.f lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .f pld tsc clc adc #&worklen+&totallen tcs phb plx ply lda &r+8 pha lda &r+6 pha lda &r+4 pha lda &r+2 pha lda &r pha phy phx plb rtl mexit .g mnote 'Not a valid return length',16 mexit .h aif &totallen=0,.i lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .i pld tsc clc adc #&worklen+&totallen tcs aif &len=0,.j tya .j rtl mend \ No newline at end of file diff --git a/Native.pas b/Native.pas new file mode 100755 index 0000000..87f8899 --- /dev/null +++ b/Native.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ORCA Native Code Generation } { } { This module of the code generator is called to generate } { native code instructions. The native code is optimized } { and written to the object segment. } { } { Externally available procedures: } { } { EndSeg - close out the current segment } { GenNative - write a native code instruction to the output } { file } { GenImplied - short form of GenNative - reduces code size } { GenCall - short form of jsl to library subroutine - reduces } { code size } { GenLab - generate a label } { InitFile - Set up the object file } { InitNative - set up for a new segment } { RefName - handle a reference to a named label } { } {---------------------------------------------------------------} unit Native; interface {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC, ObjOut; {$segment 'CodeGen'} type labelptr = ^labelentry; {pointer to a forward ref node} labelentry = record {forward ref node} addr: integer; next: labelptr; end; labelrec = record {label record} defined: boolean; {Note: form used in objout.asm} chain: labelptr; case boolean of true : (val: longint); false: (ival,hval: integer); end; var {current instruction info} {------------------------} pc: longint; {program counter} {65816 native code generation} {----------------------------} didOne: boolean; {has an optimization been done?} labeltab: array[0..maxlabel] of labelrec; {label table} localLabel: array[0..maxLocalLabel] of integer; {local variable label table} {---------------------------------------------------------------} procedure EndSeg; { close out the current segment } procedure GenNative (p_opcode: integer; p_mode: addressingMode; p_operand: integer; p_name: stringPtr; p_flags: integer); { write a native code instruction to the output file } { } { parameters: } { p_opcode - native op code } { p_mode - addressing mode } { p_operand - integer operand } { p_name - named operand } { p_flags - operand modifier flags } procedure GenImplied (p_opcode: integer); { short form of GenNative - reduces code size } { } { parameters: } { p_code - operation code } procedure GenCall (callNum: integer); { short form of jsl to library subroutine - reduces code size } { } { parameters: } { callNum - subroutine # to generate a call for } procedure GenLab (lnum: integer); { generate a label } { } { parameters: } { lnum - label number } procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean); { Set up the object file } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } { } { Note: Declared as extern in CGI.pas } procedure InitNative; { set up for a new segment } procedure LabelSearch (lab: integer; len, shift, disp: integer); { resolve a label reference } { } { parameters: } { lab - label number } { len - # bytes for the generated code } { shift - shift factor } { disp - disp past the label } { } { Note 1: maxlabel is reserved for use as the start of the } { string space } { Note 2: negative length indicates relative branch } { Note 3: zero length indicates 2 byte addr -1 } procedure RefName (lab: stringPtr; disp, len, shift: integer); { handle a reference to a named label } { } { parameters: } { lab - label name } { disp - displacement past the label } { len - number of bytes in the reference } { shift - shift factor } {--------------------------------------------------------------------------} implementation const npeepSize = 128; {native peephole optimizer window size} nMaxPeep = 4; {max # instructions needed to opt.} type {65816 native code generation} {----------------------------} npeepRange = 1..npeepsize; {subrange for native code peephole opt.} nativeType = record {native code instruction} opcode: integer; {op code} mode: addressingMode; {addressing mode} operand: integer; {operand value} name: stringPtr; {operand label} flags: integer; {modifier flags} end; registerConditions = (regUnknown,regImmediate,regAbsolute,regLocal); registerType = record {used to track register contents} condition: registerConditions; value: integer; lab: stringPtr; flags: integer; end; var {native peephole optimization} {----------------------------} aRegister, {current register contents} xRegister, yRegister: registerType; nleadOpcodes: set of 0..max_opcode; {instructions that can start an opt.} nstopOpcodes: set of 0..max_opcode; {instructions not involved in opt.} nnextspot: npeepRange; {next empty spot in npeep} npeep: array[npeepRange] of nativeType; {native peephole array} {I/O files} {---------} fname1, fname2: gsosOutString; {file names} nextSuffix: char; {next suffix character to use} procedure GenSymbols (sym: ptr; doGlobals: integer); extern; { generate the symbol table } {--------------------------------------------------------------------------} procedure LabelSearch {lab: integer; len, shift, disp: integer}; { resolve a label reference } { } { parameters: } { lab - label number } { len - # bytes for the generated code } { shift - shift factor } { disp - disp past the label } { } { Note 1: maxlabel is reserved for use as the start of the } { string space } { Note 2: negative length indicates relative branch } { Note 3: zero length indicates 2 byte addr -1 } var next: labelptr; {work pointer} begin {LabelSearch} if labeltab[lab].defined and (len < 0) and (shift = 0) and (disp = 0) then begin {handle a relative branch to a known disp} if len = -1 then CnOut(labeltab[lab].ival - long(pc).lsw - cbufflen + len) else CnOut2(labeltab[lab].ival - long(pc).lsw - cbufflen + len); end {if} else begin if lab <> maxlabel then begin {handle a normal label reference} Purge; {empty the constant buffer} if len < 0 then begin len := -len; {generate a RELEXPR} Out(238); Out(len); Out2(len); Out2(0); end {if} else begin if isJSL then {generate a standard EXPR} Out(243) else Out(235); if len = 0 then Out(2) else Out(len); end; {else} end; {if} Out(135); {generate a relative offset from the seg. start} if not labeltab[lab].defined then begin next := pointer(Malloc(sizeof(labelEntry))); {value unknown: create a reference} next^.next := labeltab[lab].chain; labeltab[lab].chain := next; next^.addr := blkcnt; Out2(0); Out2(0); end {if} else {labeltab[lab].defined} begin Out2(labeltab[lab].ival); {value known: write it} Out2(labeltab[lab].hval); end; {else} if len = 0 then begin Out(129); {subtract 1 from addr} Out2(1); Out2(0); Out(2); len := 2; end; {if} if disp <> 0 then begin Out(129); {add in the displacement} Out2(disp); if disp < 0 then Out2(-1) else Out2(0); Out(1); end; {if} if shift <> 0 then begin Out(129); {shift the address} Out2(-shift); Out2(-1); Out(7); end; {if} if lab <> maxlabel then {if not a string, end the expression} Out(0); pc := pc+len; {update the pc} end; {else} end; {LabelSearch} procedure UpDate (lab: integer; labelValue: longint); { define a label } { } { parameters: } { lab - label number } { labelValue - displacement in seg where label is located } var next,temp: labelptr; {work pointers} begin {UpDate} if labeltab[lab].defined then Error(cge1) else begin {define the label for future references} with labeltab[lab] do begin defined := true; val := labelValue; next := chain; end; {with} {resolve any forward references} if next <> nil then begin Purge; while next <> nil do begin segdisp := next^.addr; Out2(long(labelvalue).lsw); Out2(long(labelvalue).msw); blkcnt := blkcnt-4; temp := next; next := next^.next; end; {while} segdisp := blkcnt; end; {if} end; {else} end; {UpDate} procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer; name: stringPtr; flags: integer); { write a native code instruction to the output file } { } { parameters: } { opcode - native op code } { mode - addressing mode } { operand - integer operand } { name - named operand } { flags - operand modifier flags } label 1; type rkind = (k1,k2,k3); {cnv record types} var ch: char; {temp storage for string constants} cns: realRec; {for converting reals to bytes} cnv: record {for converting double, real to bytes} case rkind of k1: (rval: real;); k2: (dval: double;); k3: (ival1,ival2,ival3,ival4: integer;); end; count: integer; {number of constants to repeat} i,j,k: integer; {loop variables} lsegDisp: integer; {for backtracking while writting the } { debugger's symbol table } lval: longint; {temp storage for long constant} nptr: stringPtr; {pointer to a name} sptr: longstringPtr; {pointer to a string constant} procedure GenImmediate1; { generate a one byte immediate operand } begin {GenImmediate1} if (flags & stringReference) <> 0 then begin Purge; Out(235); Out(1); {one byte expression} Out(128); {current location ctr} Out(129); Out2(-16); Out2(-1); {-16} Out(7); {bit shift} Out(0); {end of expr} pc := pc+1; end {if} else if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 1, ord(odd(flags div shift16))*16, operand) else if (flags & shift16) <> 0 then RefName(name, operand, 1, -16) else CnOut(operand); end; {GenImmediate1} procedure GenImmediate2; { generate a two byte immediate operand } begin {GenImmediate2} if (flags & stringReference) <> 0 then begin Purge; Out(235); Out(2); LabelSearch(maxLabel, 2, 0, 0); if operand <> 0 then begin Out(129); Out2(operand); Out2(0); Out(1); end; {if} if (flags & shift16) <> 0 then begin Out(129); Out2(-16); Out2(-1); Out(7); end; {if} Out(0); end {if} else if (flags & shift8) <> 0 then RefName(name, operand, 2, -8) else if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 2, ord(odd(flags div shift16))*16, operand) else if (flags & shift16) <> 0 then RefName(name, operand, 2, -16) else if name = nil then CnOut2(operand) else RefName(name, operand, 2, 0); end; {GenImmediate2} procedure DefGlobal (private: integer); { define a global label } { } { parameters: } { private - private flag } var i: integer; {loop variable} begin {DefGlobal} Purge; Out(230); {global label definition} Out(ord(name^[0])); {write label name} for i := 1 to ord(name^[0]) do Out(ord(name^[i])); Out2(0); {length attribute} Out(ord('N')); {type attribute: other directive} Out(private); {private or global?} end; {DefGlobal} begin {WriteNative} { writeln('WriteNative: ',opcode:4, ', mode=', ord(mode):1, ' operand=', operand:1); {debug} case mode of implied: CnOut(opcode); immediate: begin if opcode = d_bmov then GenImmediate1 else begin if opcode = m_and_imm then if not longA then if operand = 255 then goto 1; CnOut(opcode); if opcode = m_pea then GenImmediate2 else if opcode in [m_adc_imm,m_and_imm,m_cmp_imm,m_eor_imm,m_lda_imm,m_ora_imm, m_sbc_imm,m_bit_imm] then if longA then GenImmediate2 else GenImmediate1 else if opcode in [m_rep,m_sep,m_cop] then begin GenImmediate1; if opcode = m_rep then begin if odd(operand div 32) then longA := true; if odd(operand div 16) then longI := true; end {if} else if opcode = m_sep then begin if odd(operand div 32) then longA := false; if odd(operand div 16) then longI := false; end; {else} end {else} else if longI then GenImmediate2 else GenImmediate1; end; {else} end; longabs: begin CnOut(opcode); isJSL := opcode = m_jsl; {allow for dynamic segs} if name = nil then if odd(flags div toolcall) then begin CnOut2(0); CnOut(225); end {if} else LabelSearch(operand, 3, 0, 0) else if odd(flags div toolcall) then begin CnOut2(long(name).lsw); CnOut(long(name).msw); end {if} else RefName(name, operand, 3, 0); isJSL := false; end; longabsolute: begin if opcode <> d_add then begin CnOut(opcode); i := 3; end {if} else i := 4; if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, i, 0, operand) else if (flags & constantOpnd) <> 0 then begin lval := ord4(name); CnOut2(long(lval).lsw); if opcode = d_add then CnOut2(long(lval).msw) else CnOut(long(lval).msw); end {else if} else if name <> nil then RefName(name, operand, i, 0) else begin CnOut2(operand); CnOut(0); if opcode = d_add then CnOut(0); end; {else} end; absolute: begin if opcode <> d_add then CnOut(opcode); if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 2, 0, operand) else if name <> nil then RefName(name, operand, 2, 0) else if (flags & constantOpnd) <> 0 then CnOut2(operand) else LabelSearch(operand, 2, 0, 0); end; direct: begin if opcode <> d_add then CnOut(opcode); if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 1, 0, operand) else if name <> nil then RefName(name, operand, 1, 0) else CnOut(operand); end; longrelative: begin CnOut(opcode); LabelSearch(operand, -2, 0, 0); end; relative: begin CnOut(opcode); LabelSearch(operand, -1, 0, 0); end; gnrLabel: if name = nil then UpDate(operand, pc+cbufflen) else begin DefGlobal((flags >> 5) & 1); if operand <> 0 then begin Out(241); Out2(operand); Out2(0); pc := pc+operand; end; {if} end; {else} gnrSpace: if operand <> 0 then begin Out(241); Out2(operand); Out2(0); pc := pc+operand; end; {if} gnrConstant: begin if icptr(name)^.optype = cgString then count := 1 else count := icptr(name)^.q; for i := 1 to count do case icptr(name)^.optype of cgByte,cgUByte : CnOut(icptr(name)^.r); cgWord,cgUWord : CnOut2(icptr(name)^.r); cgLong,cgULong : begin lval := icptr(name)^.lval; CnOut2(long(lval).lsw); CnOut2(long(lval).msw); end; cgReal : begin cnv.rval := icptr(name)^.rval; CnOut2(cnv.ival1); CnOut2(cnv.ival2); end; cgDouble : begin cnv.dval := icptr(name)^.rval; CnOut2(cnv.ival1); CnOut2(cnv.ival2); CnOut2(cnv.ival3); CnOut2(cnv.ival4); end; cgComp : begin cns.itsReal := icptr(name)^.rval; CnvSC(cns); for j := 1 to 8 do CnOut(cns.inCOMP[j]); end; cgExtended : begin cns.itsReal := icptr(name)^.rval; CnvSX(cns); for j := 1 to 10 do CnOut(cns.inSANE[j]); end; cgString : begin sptr := icptr(name)^.str; for j := 1 to sptr^.length do CnOut(ord(sPtr^.str[j])); end; ccPointer : begin if icptr(name)^.lab <> nil then begin Purge; Out(235); Out(4); Out(131); pc := pc+4; nptr := icptr(name)^.lab; for j := 0 to ord(nptr^[0]) do Out(ord(nptr^[j])); lval := icptr(name)^.pVal; if lval <> 0 then begin Out(129); Out2(long(lval).lsw); Out2(long(lval).msw); Out(2-icptr(name)^.r); end; {if} Out(0); end {if} else begin lval := icptr(name)^.pVal; if icptr(name)^.r = 1 then operand := stringSize+long(lval).lsw else operand := stringSize-long(lval).lsw; flags := stringReference; GenImmediate2; flags := stringReference+shift16; GenImmediate2; sptr := icptr(name)^.pStr; j := sptr^.length; if maxString-stringSize >= j+1 then begin for k := 1 to j do stringSpace[k+stringSize] := sptr^.str[k]; stringSpace[stringSize+j+1] := chr(0); stringSize := stringSize+j+1; end {if} else Error(cge3); end; {else} end; otherwise : Error(cge1); end; {case} end; genAddress: begin if opcode < 256 then CnOut(opcode); if (flags & stringReference) <> 0 then begin Purge; Out(235); Out(2); LabelSearch(maxLabel,2,0,0); if operand <> 0 then begin Out(129); Out2(operand); Out2(0); Out(1); end; {if} if (flags & shift16) <> 0 then begin Out(129); Out2(-16); Out2(-1); Out(7); end; {if} Out(0); end {if} else if operand = 0 then begin CnOut(0); CnOut(0); end {else if} else if (flags & shift16) <> 0 then if longA then LabelSearch(operand, 2, 16, 0) else LabelSearch(operand, 1, 16, 0) else LabelSearch(operand, 0, 0, 0); end; special: if opcode = d_pin then begin segDisp := 36; out2(long(pc).lsw+cBuffLen); blkCnt := blkCnt-2; segDisp := blkCnt; end {if} else if opcode = d_sym then begin CnOut(m_cop); CnOut(5); Purge; lsegDisp := segDisp+1; CnOut2(0); symLength := 0; GenSymbols(pointer(name), operand); segDisp := lSegDisp; out2(symLength); blkCnt := blkCnt-2; segDisp := blkCnt; end {else if} else {d_wrd} CnOut2(operand); otherwise: Error(cge1); end; {case} 1: end; {WriteNative} procedure CheckRegisters(p_opcode: integer; p_mode: addressingMode; p_operand: integer; p_name: stringPtr; p_flags: integer); { write a native code instruction to the output file } { } { parameters: } { p_opcode - native op code } { p_mode - addressing mode } { p_operand - integer operand } { p_name - named operand } { p_flags - operand modifier flags } label 1,2; begin {CheckRegisters} case p_opcode of m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir,m_and_imm, m_and_s,m_asl_a,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s,m_lda_absx, m_lda_dirx,m_lda_indl,m_lda_indly,m_lda_longx,m_lda_s,m_lsr_a,m_ora_abs, m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s,m_pla,m_sbc_abs, m_sbc_dir,m_sbc_imm,m_sbc_s,m_tdc,m_tsc,m_tsb_dir,m_tsb_abs: aRegister.condition := regUnknown; m_ldy_absX,m_ldy_dirX,m_ply: yRegister.condition := regUnknown; m_plx: xRegister.condition := regUnknown; m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_clc,m_cmp_abs, m_cmp_dir,m_cmp_imm,m_cmp_s,m_cpx_imm,m_jml,m_pha,m_phb,m_phd, m_phx,m_phy,m_plb,m_pld,m_rtl,m_rts,m_sec,m_sta_absX, m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_longX, m_sta_s,m_stx_dir,m_sty_dir,m_sty_dirX,m_stz_abs,m_stz_absX, m_stz_dir,m_stz_dirX,m_tcs,m_tcd,d_add,d_pin,m_pei_dir,m_cpx_abs, m_cpx_dir,m_cmp_dirx,m_php,m_plp,m_cop,d_wrd: ; m_pea: begin if aRegister.condition = regImmediate then if aRegister.value = p_operand then if aRegister.lab = p_name then if aRegister.flags = p_flags then if longA then begin p_opcode := m_pha; p_mode := implied; goto 2; end; {if} if longI then begin if xRegister.condition = regImmediate then if xRegister.value = p_operand then if xRegister.lab = p_name then if xRegister.flags = p_flags then begin p_opcode := m_phx; p_mode := implied; goto 2; end; {if} if yRegister.condition = regImmediate then if yRegister.value = p_operand then if yRegister.lab = p_name then if yRegister.flags = p_flags then begin p_opcode := m_phy; p_mode := implied; goto 2; end; {if} end; {if} end; m_dec_abs,m_inc_abs,m_sta_abs,m_stx_abs,m_sty_abs,m_sta_long: begin if aRegister.condition = regAbsolute then if aRegister.lab = p_name then if aRegister.value = p_operand then if not (p_opcode in [m_sta_abs,m_sta_long]) then aRegister.condition := regUnknown; if xRegister.condition = regAbsolute then if xRegister.lab = p_name then if xRegister.value = p_operand then if p_opcode <> m_stx_abs then xRegister.condition := regUnknown; if yRegister.condition = regAbsolute then if yRegister.lab = p_name then if yRegister.value = p_operand then if p_opcode <> m_sty_abs then yRegister.condition := regUnknown; end; m_dec_dir,m_dec_dirX,m_inc_dir,m_inc_dirX: begin if aRegister.condition = regLocal then if aRegister.value = p_operand then aRegister.condition := regUnknown; if xRegister.condition = regLocal then if xRegister.value = p_operand then xRegister.condition := regUnknown; if yRegister.condition = regLocal then if yRegister.value = p_operand then yRegister.condition := regUnknown; end; m_dex: if xRegister.condition = regImmediate then xRegister.value := xRegister.value-1 else xRegister.condition := regUnknown; m_dey: if yRegister.condition = regImmediate then yRegister.value := yRegister.value-1 else yRegister.condition := regUnknown; m_ina: if aRegister.condition = regImmediate then aRegister.value := aRegister.value+1 else aRegister.condition := regUnknown; m_inx: if xRegister.condition = regImmediate then xRegister.value := xRegister.value+1 else xRegister.condition := regUnknown; m_iny: if yRegister.condition = regImmediate then yRegister.value := yRegister.value+1 else yRegister.condition := regUnknown; otherwise, m_jsl,m_mvn,m_rep,m_sep,d_lab,d_end,d_bmov,d_cns: begin aRegister.condition := regUnknown; xRegister.condition := regUnknown; yRegister.condition := regUnknown; end; m_lda_abs,m_lda_long: begin if (aRegister.condition = regAbsolute) and (aRegister.value = p_operand) and (aRegister.lab = p_name) then goto 1 else if longA = longI then begin if (xRegister.condition = regAbsolute) and (xRegister.value = p_operand) and (xRegister.lab = p_name) then begin p_opcode := m_txa; p_mode := implied; aRegister := xRegister; goto 2; end {if} else if (yRegister.condition = regAbsolute) and (yRegister.value = p_operand) and (yRegister.lab = p_name) then begin p_opcode := m_tya; p_mode := implied; aRegister := yRegister; goto 2; end; {else if} end; aRegister.condition := regAbsolute; aRegister.value := p_operand; aRegister.lab := p_name; aRegister.flags := p_flags; end; m_lda_dir: begin if (aRegister.condition = regLocal) and (aRegister.value = p_operand) then goto 1 else if longA = longI then begin if (xRegister.condition = regLocal) and (xRegister.value = p_operand) then begin p_opcode := m_txa; p_mode := implied; aRegister := xRegister; goto 2; end {if} else if (yRegister.condition = regLocal) and (yRegister.value = p_operand) then begin p_opcode := m_tya; p_mode := implied; aRegister := yRegister; goto 2; end; {else if} end; {else if} aRegister.condition := regLocal; aRegister.value := p_operand; aRegister.flags := p_flags; end; m_lda_imm: begin if (aRegister.condition = regImmediate) and (aRegister.value = p_operand) and (aRegister.lab = p_name) and (aRegister.flags = p_flags) then goto 1 else if longA = longI then begin if (xRegister.condition = regImmediate) and (xRegister.value = p_operand) and (xRegister.lab = p_name) and (xRegister.flags = p_flags) then begin p_opcode := m_txa; p_mode := implied; aRegister := xRegister; goto 2; end {if} else if (yRegister.condition = regImmediate) and (yRegister.value = p_operand) and (yRegister.lab = p_name) and (yRegister.flags = p_flags) then begin p_opcode := m_tya; p_mode := implied; aRegister := yRegister; goto 2; end; {else if} end; {else if} if (aRegister.condition = regImmediate) and (aRegister.lab = p_name) and (aRegister.flags = p_flags) then if aRegister.value = (p_operand + 1) then begin p_opcode := m_dea; p_mode := implied; aRegister.value := p_operand; goto 2; end {if} else if aRegister.value = (p_operand - 1) then begin p_opcode := m_ina; p_mode := implied; aRegister.value := p_operand; goto 2; end; {else if} aRegister.condition := regImmediate; aRegister.value := p_operand; aRegister.flags := p_flags; aRegister.lab := p_name; end; m_ldx_abs: begin if (xRegister.condition = regAbsolute) and (xRegister.value = p_operand) and (xRegister.lab = p_name) then goto 1 else if (aRegister.condition = regAbsolute) and (aRegister.value = p_operand) and (aRegister.lab = p_name) and (longA = longI) then begin p_opcode := m_tax; p_mode := implied; xRegister := aRegister; end {else if} else if (yRegister.condition = regAbsolute) and (yRegister.value = p_operand) and (yRegister.lab = p_name) then begin p_opcode := m_tyx; p_mode := implied; xRegister := yRegister; end {else if} else begin xRegister.condition := regAbsolute; xRegister.value := p_operand; xRegister.lab := p_name; xRegister.flags := p_flags; end; {else} end; m_ldx_dir: begin if (xRegister.condition = regLocal) and (xRegister.value = p_operand) then goto 1 else if (aRegister.condition = regLocal) and (aRegister.value = p_operand) and (longA = longI) then begin p_opcode := m_tax; p_mode := implied; xRegister := aRegister; end {else if} else if (yRegister.condition = regLocal) and (yRegister.value = p_operand) then begin p_opcode := m_tyx; p_mode := implied; xRegister := yRegister; end {else if} else begin xRegister.condition := regLocal; xRegister.value := p_operand; xRegister.flags := p_flags; end; {else} end; m_ldx_imm: begin if (xRegister.condition = regImmediate) and (xRegister.value = p_operand) and (xRegister.lab = p_name) and (xRegister.flags = p_flags) then goto 1 else if (aRegister.condition = regImmediate) and (aRegister.value = p_operand) and (longA = longI) and (aRegister.lab = p_name) and (aRegister.flags = p_flags) then begin p_opcode := m_tax; p_mode := implied; xRegister := aRegister; end {else} else if (yRegister.condition = regImmediate) and (yRegister.value = p_operand) and (yRegister.lab = p_name) and (yRegister.flags = p_flags) then begin p_opcode := m_tyx; p_mode := implied; xRegister := yRegister; end {else if} else begin if (xRegister.condition = regImmediate) and (xRegister.lab = p_name) and (xRegister.flags = p_flags) then if xRegister.value = (p_operand + 1) then begin p_opcode := m_dex; p_mode := implied; xRegister.value := p_operand; goto 2; end {if} else if xRegister.value = (p_operand - 1) then begin p_opcode := m_inx; p_mode := implied; xRegister.value := p_operand; goto 2; end; {else if} xRegister.condition := regImmediate; xRegister.value := p_operand; xRegister.flags := p_flags; xRegister.lab := p_name; end; {else} end; m_ldy_abs: begin if (yRegister.condition = regAbsolute) and (yRegister.value = p_operand) and (yRegister.lab = p_name) then goto 1 else if (aRegister.condition = regAbsolute) and (aRegister.value = p_operand) and (aRegister.lab = p_name) and (longA = longI) then begin p_opcode := m_tay; p_mode := implied; yRegister := aRegister; end {else if} else if (xRegister.condition = regAbsolute) and (xRegister.value = p_operand) and (xRegister.lab = p_name) then begin p_opcode := m_txy; p_mode := implied; yRegister := xRegister; end {else if} else begin yRegister.condition := regAbsolute; yRegister.value := p_operand; yRegister.lab := p_name; yRegister.flags := p_flags; end; {else} end; m_ldy_dir: begin if (yRegister.condition = regLocal) and (yRegister.value = p_operand) then goto 1 else if (aRegister.condition = regLocal) and (aRegister.value = p_operand) and (longA = longI) then begin p_opcode := m_tay; p_mode := implied; yRegister := aRegister; end {else if} else if (xRegister.condition = regLocal) and (xRegister.value = p_operand) then begin p_opcode := m_txy; p_mode := implied; yRegister := xRegister; end {else if} else begin yRegister.condition := regLocal; yRegister.value := p_operand; yRegister.flags := p_flags; end; {else} end; m_ldy_imm: begin if (yRegister.condition = regImmediate) and (yRegister.value = p_operand) and (yRegister.lab = p_name) and (yRegister.flags = p_flags) then goto 1 else if (aRegister.condition = regImmediate) and (aRegister.value = p_operand) and (aRegister.flags = p_flags) and (aRegister.lab = p_name) and (longA = longI) then begin p_opcode := m_tay; p_mode := implied; yRegister := aRegister; end {else if} else if (xRegister.condition = regImmediate) and (xRegister.value = p_operand) and (xRegister.lab = p_name) and (xRegister.flags = p_flags) then begin p_opcode := m_txy; p_mode := implied; yRegister := xRegister; end {else if} else begin if (yRegister.condition = regImmediate) and (yRegister.lab = p_name) and (yRegister.flags = p_flags) then if yRegister.value = (p_operand + 1) then begin p_opcode := m_dey; p_mode := implied; yRegister.value := p_operand; goto 2; end {if} else if yRegister.value = (p_operand - 1) then begin p_opcode := m_iny; p_mode := implied; yRegister.value := p_operand; goto 2; end; {else if} yRegister.condition := regImmediate; yRegister.value := p_operand; yRegister.flags := p_flags; yRegister.lab := p_name; end; {else} end; m_tax: begin if aRegister.condition <> regUnknown then if aRegister.condition = xRegister.condition then if aRegister.value = xRegister.value then if aRegister.flags = xRegister.flags then if aRegister.condition <> regAbsolute then goto 1 else if aRegister.lab = xRegister.lab then goto 1; xRegister := aRegister; end; m_tay: begin if aRegister.condition <> regUnknown then if aRegister.condition = yRegister.condition then if aRegister.value = yRegister.value then if aRegister.flags = yRegister.flags then if aRegister.condition <> regAbsolute then goto 1 else if aRegister.lab = yRegister.lab then goto 1; yRegister := aRegister; end; m_txa: begin if xRegister.condition <> regUnknown then if xRegister.condition = aRegister.condition then if xRegister.value = aRegister.value then if xRegister.flags = aRegister.flags then if xRegister.condition <> regAbsolute then goto 1 else if xRegister.lab = aRegister.lab then goto 1; aRegister := xRegister; end; m_txy: begin if xRegister.condition <> regUnknown then if xRegister.condition = yRegister.condition then if xRegister.value = yRegister.value then if xRegister.flags = yRegister.flags then if xRegister.condition <> regAbsolute then goto 1 else if xRegister.lab = yRegister.lab then goto 1; yRegister := xRegister; end; m_tya: begin if yRegister.condition <> regUnknown then if yRegister.condition = aRegister.condition then if yRegister.value = aRegister.value then if yRegister.flags = aRegister.flags then if yRegister.condition <> regAbsolute then goto 1 else if yRegister.lab = aRegister.lab then goto 1; aRegister := yRegister; end; m_tyx: begin if yRegister.condition <> regUnknown then if yRegister.condition = xRegister.condition then if yRegister.value = xRegister.value then if yRegister.flags = xRegister.flags then if yRegister.condition <> regAbsolute then goto 1 else if yRegister.lab = xRegister.lab then goto 1; xRegister := yRegister; end; end; {case} 2: WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags); 1: end; {CheckRegisters} procedure Remove (ns: integer); extern; { Remove the instruction ns from the peephole array } { } { parameters: } { ns - index of the instruction to remove } function Short (n, lab: integer): boolean; extern; { see if a label is within range of a one-byte relative branch } { } { parameters: } { n - index to branch instruction } { lab - label number } {--------------------------------------------------------------------------} procedure EndSeg; { close out the current segment } var i: integer; begin {EndSeg} Purge; {dump constant buffer} if stringsize <> 0 then begin {define string space} UpDate(maxLabel, pc); {define the local label for the string space} for i := 1 to stringsize do CnOut(ord(stringspace[i])); Purge; end; {if} Out(0); {end the segment} segDisp := 8; {update header} Out2(long(pc).lsw); Out2(long(pc).msw); blkcnt := blkcnt-4; {purge the segment to disk} segDisp := blkcnt; CloseSeg; end; {EndSeg} procedure GenNative {p_opcode: integer; p_mode: addressingMode; p_operand: integer; p_name: stringPtr; p_flags: integer}; { write a native code instruction to the output file } { } { parameters: } { p_opcode - native op code } { p_mode - addressing mode } { p_operand - integer operand } { p_name - named operand } { p_flags - operand modifier flags } var done: boolean; {loop termination} llongA: boolean; {for tracking A size during opt.} i: integer; {index} op: integer; {temp storage for opcode} procedure Purge; { Empty the peephole array } begin {Purge} while nnextSpot > 1 do begin if registers then CheckRegisters(npeep[1].opcode, npeep[1].mode, npeep[1].operand, npeep[1].name, npeep[1].flags) else WriteNative(npeep[1].opcode, npeep[1].mode, npeep[1].operand, npeep[1].name, npeep[1].flags); Remove(1); end; {while} end; {Purge} procedure Optimize(ns: integer; longA: boolean); { Optimize the instruction starting at ns } { } { parameters: } { ns - index of instruction to check for optimization } { longA - is the accumulator long? } label 1; var tn: nativeType; {temp operation} function ASafe (ns: integer): boolean; { See if it is safe to skip loading the A register } { } { parameters: } { ns - starting index } label 1; var i: integer; {loop variable} opcode: integer; {copy of current op code} begin {ASafe} ASafe := false; for i := ns to nnextSpot-1 do begin opcode := npeep[i].opcode; if opcode in [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bra,m_brl,m_bvs,m_jml,m_jsl, m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm,m_lda_indl, m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_mvn,m_pla,m_rtl, m_rts,m_tdc,m_txa,m_tya,m_tsc,d_end,d_bmov,d_add,d_pin,d_wrd, d_sym,d_cns] then begin ASafe := true; goto 1; end {if} else if opcode in [m_adc_abs,m_adc_dir,m_adc_imm,m_adc_s,m_and_abs,m_and_dir, m_and_imm,m_and_s,m_asl_a,m_cmp_abs,m_cmp_dir,m_cmp_dirX,m_cmp_imm, m_cmp_long,m_cmp_s,m_dea,m_eor_abs,m_eor_dir,m_eor_imm,m_eor_s, m_ina,m_lda_abs,m_lda_absx,m_lda_dir,m_lda_dirx,m_lda_imm, m_lda_indl,m_lda_indly,m_lda_long,m_lda_longx,m_lda_s,m_lsr_a, m_ora_abs,m_ora_dir,m_ora_dirX,m_ora_imm,m_ora_longX,m_ora_s, m_pha,m_sbc_abs,m_sbc_dir,m_sbc_imm,m_sbc_s,m_sta_abs,m_sta_absX, m_sta_dir,m_sta_dirX,m_sta_indl,m_sta_indlY,m_sta_long,m_sta_longX, m_sta_s,m_tax,m_tay,m_tcd,m_tcs,m_xba,m_tsb_dir,m_tsb_abs] then goto 1; end; {for} 1: end; {ASafe} function SignExtension (ns: integer): boolean; { See if the pattern is a sugn extension } { } { Parameters: } { ns - start of suspected pattern } { } { Returns: true for a sign extension, else false } begin {SignExtension} SignExtension := false; if npeep[ns].opcode = m_ldx_imm then if npeep[ns].operand = 0 then if npeep[ns+1].opcode = m_tay then if npeep[ns+2].opcode = m_bpl then if npeep[ns+3].opcode = m_dex then SignExtension := true; end; {SignExtension} begin {Optimize} with npeep[ns] do case opcode of m_and_imm: if npeep[ns+1].opcode = m_and_imm then begin operand := operand & npeep[ns+1].operand; Remove(ns+1); end; {if} m_asl_a: if npeep[ns+1].opcode = m_tay then if npeep[ns+2].opcode = m_iny then if npeep[ns+3].opcode = m_iny then begin opcode := m_ina; npeep[ns+1].opcode := m_asl_a; npeep[ns+2].opcode := m_tay; Remove(ns+3); end; {if} m_bcs,m_beq,m_bne,m_bmi,m_bpl,m_bcc: if npeep[ns+2].opcode = d_lab then if npeep[ns+2].operand = operand then if npeep[ns+1].opcode = m_brl then begin if Short(ns,npeep[ns+1].operand) then begin operand := npeep[ns+1].operand; Remove(ns+1); if opcode = m_bcs then opcode := m_bcc else if opcode = m_beq then opcode := m_bne else if opcode = m_bne then opcode := m_beq else if opcode = m_bmi then opcode := m_bpl else if opcode = m_bcc then opcode := m_bcs else opcode := m_bmi; end; {if} end {if m_brl} else if npeep[ns+1].opcode = m_bra then begin operand := npeep[ns+1].operand; Remove(ns+1); Remove(ns+1); if opcode = m_bcs then opcode := m_bcc else if opcode = m_beq then opcode := m_bne else if opcode = m_bne then opcode := m_beq else if opcode = m_bmi then opcode := m_bpl else if opcode = m_bcc then opcode := m_bcs else opcode := m_bmi; end; {else if m_bra} m_brl: if Short(ns,operand) then begin opcode := m_bra; mode := relative; didOne := true; end; {if} m_bvs: if npeep[ns+2].opcode = d_lab then if npeep[ns+2].operand = operand then if npeep[ns+1].opcode = m_bmi then if npeep[ns+4].opcode = d_lab then if npeep[ns+1].operand = npeep[ns+4].operand then if npeep[ns+3].opcode = m_brl then if Short(ns,npeep[ns+3].operand) then if Short(ns+1,npeep[ns+3].operand) then begin operand := npeep[ns+3].operand; npeep[ns+1].operand := npeep[ns+3].operand; npeep[ns+1].opcode := m_bpl; Remove(ns+3); end; {if} m_dec_abs: if npeep[ns+1].opcode = m_lda_abs then if name^ = npeep[ns+1].name^ then if npeep[ns+2].opcode = m_beq then Remove(ns+1); m_lda_abs: if npeep[ns+1].opcode = m_clc then begin if npeep[ns+2].opcode = m_adc_abs then if operand = npeep[ns+2].operand then if name = npeep[ns+2].name then if not rangeCheck then begin npeep[ns+1].opcode := m_asl_a; Remove(ns+2); end; {if} end {if} else if npeep[ns+1].opcode = m_dea then begin if npeep[ns+2].opcode = m_tax then begin opcode := m_ldx_abs; npeep[ns+1].opcode := m_dex; Remove(ns+2); end; {if} end {else if} else if npeep[ns+2].opcode = m_sta_abs then begin if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX, m_ora_imm,m_ora_longX,m_ora_s] then if operand = npeep[ns+2].operand then if name = npeep[ns+2].name then begin npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0; npeep[ns+2].opcode := m_tsb_abs; Remove(ns); end; {if} end {else if} else if SignExtension(ns+1) then begin npeep[ns+2] := npeep[ns]; Remove(ns); end {else if} else if npeep[ns+1].opcode = m_xba then if npeep[ns+2].opcode = m_and_imm then if npeep[ns+2].operand = $00FF then begin operand := operand+1; Remove(ns+1); end; {if} m_lda_dir: if npeep[ns+1].opcode = m_clc then begin if npeep[ns+2].opcode = m_adc_dir then if operand = npeep[ns+2].operand then if not rangeCheck then begin npeep[ns+1].opcode := m_asl_a; Remove(ns+2); end; {if} end else if npeep[ns+1].opcode = m_dea then begin if npeep[ns+2].opcode = m_tax then begin opcode := m_ldx_dir; npeep[ns+1].opcode := m_dex; Remove(ns+2); end; {if} end {else if} else if npeep[ns+1].opcode = m_pha then begin if longA then begin opcode := m_pei_dir; Remove(ns+1); end {if} end {else if} else if npeep[ns+2].opcode = m_sta_dir then begin if npeep[ns+1].opcode in [m_ora_dir,m_ora_abs,m_ora_dirX, m_ora_imm,m_ora_longX,m_ora_s] then if operand = npeep[ns+2].operand then begin npeep[ns+1].opcode := npeep[ns+1].opcode + $00A0; npeep[ns+2].opcode := m_tsb_dir; Remove(ns); end {if} end {else if} else if SignExtension(ns+1) then begin npeep[ns+2] := npeep[ns]; Remove(ns); end {else if} else if npeep[ns+1].opcode = m_xba then if npeep[ns+2].opcode = m_and_imm then if npeep[ns+2].operand = $00FF then begin operand := operand+1; Remove(ns+1); end; {if} m_pei_dir: if npeep[ns+1].opcode = m_pla then begin opcode := m_lda_dir; Remove(ns+1); end; {if} m_lda_imm: if npeep[ns+1].opcode = m_pha then if ASafe(ns+2) then if longA then begin opcode := m_pea; Remove(ns+1); end; {if} m_ldx_imm: if npeep[ns+1].opcode = m_lda_imm then if npeep[ns+2].opcode = m_phx then if npeep[ns+3].opcode = m_pha then begin opcode := m_pea; npeep[ns+1].opcode := m_pea; Remove(ns+2); Remove(ns+2); end; {if} m_ldy_imm: if npeep[ns+1].opcode = m_sep then if npeep[ns+1].operand = 32 then begin didOne := true; tn := npeep[ns]; npeep[ns] := npeep[ns+1]; npeep[ns+1] := tn; end; {if} m_ora_abs: if npeep[ns+1].opcode = m_sta_abs then if operand = npeep[ns+1].operand then if name = npeep[ns+1].name then begin opcode := m_tsb_abs; Remove(ns+1); end; {if} m_ora_dir: if npeep[ns+1].opcode = m_sta_dir then if operand = npeep[ns+1].operand then begin opcode := m_tsb_dir; Remove(ns+1); end; {if} m_pea: if npeep[ns+1].opcode = m_pla then begin opcode := m_lda_imm; Remove(ns+1); end; {if} m_sta_abs: if npeep[ns+1].opcode = m_lda_abs then if operand = npeep[ns+1].operand then if name = npeep[ns+1].name then if not (npeep[ns+2].opcode in [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then Remove(ns+1); m_sta_dir: if npeep[ns+1].opcode = m_lda_dir then if operand = npeep[ns+1].operand then if not (npeep[ns+2].opcode in [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then Remove(ns+1); m_plb: if npeep[ns+1].opcode = m_phb then begin Remove(ns); Remove(ns); end; {if} m_plx: if npeep[ns+1].opcode = m_pha then begin opcode := m_sta_s; mode := direct; operand := 1; Remove(ns+1); end; {if} m_tax: if npeep[ns+1].opcode = m_phx then begin Remove(ns+1); opcode := m_pha; end {if} else if npeep[ns+1].opcode = m_txa then begin if not (npeep[ns+2].opcode in [m_bcc,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_bvs]) then begin Remove(ns); Remove(ns); end; {if} end {else if} else if npeep[ns+1].opcode = m_dey then if npeep[ns+2].opcode = m_dey then if npeep[ns+3].opcode = m_lda_indly then if npeep[ns+4].opcode = m_stx_dir then begin npeep[ns] := npeep[ns+4]; opcode := m_sta_dir; Remove(ns+4); end; {if} m_tya: if npeep[ns+1].opcode = m_sta_dir then begin npeep[ns+1].opcode := m_sty_dir; Remove(ns); end {if} else if npeep[ns+1].opcode = m_sta_abs then begin npeep[ns+1].opcode := m_sty_abs; Remove(ns); end; {else if} m_tyx: if npeep[ns+1].opcode = m_phx then begin Remove(ns+1); opcode := m_phy; end; {if} m_pha: if npeep[ns+1].opcode = m_pla then begin Remove(ns); Remove(ns); end {if} else if npeep[ns+1].opcode in [m_ldx_abs,m_ldx_dir] then if npeep[ns+2].opcode = m_pla then begin Remove(ns+2); Remove(ns); end; {if} m_phy: if npeep[ns+1].opcode = m_ply then begin Remove(ns); Remove(ns); end; {if} m_rep: if npeep[ns+1].opcode = m_sep then if npeep[ns].operand = npeep[ns+1].operand then begin Remove(ns); Remove(ns); end; {if} otherwise: ; end; {case} 1: end; {Optimize} begin {GenNative} { writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1, ' operand=', p_operand:1); {debug} if npeephole then begin if (nnextspot = 1) and not (p_opcode in nleadOpcodes) then begin if p_opcode <> d_end then if registers then CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags) else WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags); end {if} else if p_opcode in nstopOpcodes then begin repeat didOne := false; i := 1; llongA := longA; while i < nnextSpot-nMaxPeep do begin op := npeep[i].opcode; if op = m_sep then begin if npeep[i].operand & $20 <> 0 then llongA := false; end {if} else if op = m_rep then begin if npeep[i].operand & $20 <> 0 then llongA := true; end; {else} Optimize(i,llongA); i := i+1; end; {while} until not didone; Purge; if p_opcode <> d_end then if registers then CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags) else WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags); end {else if} else if nnextSpot = npeepSize then begin repeat didOne := false; i := 1; llongA := longA; while i < nnextSpot-nMaxPeep do begin op := npeep[i].opcode; if op = m_sep then begin if npeep[i].operand & $20 <> 0 then llongA := false; end {if} else if op = m_rep then begin if npeep[i].operand & $20 <> 0 then llongA := true; end; {else} Optimize(i,llongA); i := i+1; end; {while} until not didone; done := false; repeat if nnextSpot = 1 then done := true else begin if npeep[1].opcode in nleadOpcodes then done := true else begin if registers then CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand, nPeep[1].name, nPeep[1].flags) else WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand, nPeep[1].name,nPeep[1].flags); Remove(1); end; {else} end; {else} until done; if nnextSpot = nPeepSize then begin if registers then CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand, nPeep[1].name, nPeep[1].flags) else WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand, nPeep[1].name, nPeep[1].flags); Remove(1); end; {if} with npeep[nnextSpot] do begin opcode := p_opcode; mode := p_mode; operand := p_operand; name := p_name; flags := p_flags; end; {with} nnextSpot := nnextSpot+1; if not (npeep[1].opcode in nleadOpcodes) then begin if registers then CheckRegisters(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand, nPeep[1].name, nPeep[1].flags) else WriteNative(nPeep[1].opcode, nPeep[1].mode, nPeep[1].operand, nPeep[1].name, nPeep[1].flags); Remove(1); end; {if} end {else if} else begin with npeep[nnextSpot] do begin opcode := p_opcode; mode := p_mode; operand := p_operand; name := p_name; flags := p_flags; end; {with} nnextSpot := nnextSpot+1; end; {else} end {if} else if p_opcode <> d_end then if registers then CheckRegisters(p_opcode, p_mode, p_operand, p_name, p_flags) else WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags); end; {GenNative} procedure GenImplied {p_opcode: integer}; { short form of GenNative - reduces code size } { } { parameters: } { p_code - operation code } begin {GenImplied} GenNative(p_opcode, implied, 0, nil, 0); end; {GenImplied} procedure GenCall {callNum: integer}; { short form of jsl to library subroutine - reduces code size } { } { parameters: } { callNum - subroutine # to generate a call for } var sp: stringPtr; {work string} begin {GenCall} case callNum of 1: sp := @'~CHECKSTACK'; 2: sp := @'~RESETNAME'; 3: sp := @'~CREALRET'; 4: sp := @'~CDOUBLERET'; 5: sp := @'~SETNAME'; 6: sp := @'~SETLINENUMBER'; 7: sp := @'~REALFN'; 8: sp := @'~DOUBLEFN'; 9: sp := @'~SAVEREAL'; 10: sp := @'~SAVEDOUBLE'; 11: sp := @'~CNVINTREAL'; 12: sp := @'~CNVLONGREAL'; 13: sp := @'~CNVULONGREAL'; 14: sp := @'~CNVREALINT'; 15: sp := @'~CNVREALUINT'; 16: sp := @'~CNVREALLONG'; 17: sp := @'~CNVREALULONG'; 18: sp := @'~CNVL2'; {PASCAL} 19: sp := @'~SAVESET'; 20: sp := @'~LOADSET'; {PASCAL} 21: sp := @'~LOADREAL'; 22: sp := @'~LOADDOUBLE'; 23: sp := @'~SHIFTLEFT'; 24: sp := @'~SSHIFTRIGHT'; 25: sp := @'~INTCHKC'; 26: sp := @'~DIV2'; 27: sp := @'~MOD2'; 28: sp := @'~MUL2'; 29: sp := @'~GRTL'; 30: sp := @'~GEQL'; 31: sp := @'~GRTE'; 32: sp := @'~GEQE'; 33: sp := @'~SETINCLUSION'; 34: sp := @'~GRTSTRING'; 35: sp := @'~GEQSTRING'; 36: sp := @'~EQUE'; 37: sp := @'~SETEQU'; 38: sp := @'~EQUSTRING'; 39: sp := @'~UMUL2'; 40: sp := @'~UDIV2'; 41: sp := @'~USHIFTRIGHT'; 42: sp := @'~MUL4'; 43: sp := @'~PDIV4'; 44: sp := @'~MOD4'; 45: sp := @'~SHL4'; 46: sp := @'~LSHR4'; 47: sp := @'~ASHR4'; {CC} 48: sp := @'~UMUL4'; {CC} 49: sp := @'~UDIV4'; {CC} 50: sp := @'~UMOD4'; {CC} 51: sp := @'~COPYREAL'; 52: sp := @'~COPYDOUBLE'; 53: sp := @'~XJPERROR'; 54: sp := @'~MOVE'; 55: sp := @'~MOVE2'; 56: sp := @'~ADDE'; 57: sp := @'~DIVE'; 58: sp := @'~MULE'; 59: sp := @'~SUBE'; 60: sp := @'~POWER'; 61: sp := @'~ARCTAN2E'; 62: sp := @'~LONGMOVE'; 63: sp := @'~LONGMOVE2'; 64: sp := @'~CCOMPRET'; 65: sp := @'~CEXTENDEDRET'; 66: sp := @'~SAVECOMP'; 67: sp := @'~SAVEEXTENDED'; 68: sp := @'~COPYCOMP'; 69: sp := @'~COPYEXTENDED'; 70: sp := @'~LOADCOMP'; 71: sp := @'~LOADEXTENDED'; 72: sp := @'~LOADUBF'; 73: sp := @'~LOADBF'; 74: sp := @'~SAVEBF'; 75: sp := @'~COPYBF'; 76: sp := @'~STACKERR'; {CC} 77: sp := @'~LOADSTRUCT'; {CC} otherwise: Error(cge1); end; {case} GenNative(m_jsl, longabs, 0, sp, 0); end; {GenCall} procedure GenLab {lnum: integer}; { generate a label } { } { parameters: } { lnum - label number } begin {GenLab} GenNative(d_lab, gnrlabel, lnum, nil, 0); end; {GenLab} procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean}; { Set up the object file } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } { } { Note: Declared as extern in CGI.pas } procedure RootFile; { Create and write the initial entry segment } const dispToOpen = 21; {disps to glue routines for NDAs} dispToClose = 38; dispToAction = 50; dispToInit = 65; dispToCDAOpen = 9; {disps to glue routines for CDAs} dispToCDAClose = 36; var i: integer; {loop index} lab: stringPtr; {for holdling names var pointers} menuLen: integer; {length of the menu name string} procedure SetDataBank; { set up the data bank register } begin {SetDataBank} CnOut(m_pea); RefName(@'~GLOBALS', 0, 2, -8); CnOut(m_plb); CnOut(m_plb); end; {SetDataBank} begin {RootFile} {open the initial object module} fname2.theString.theString := concat(fname1.theString.theString, '.root'); fname2.theString.size := length(fname2.theString.theString); OpenObj(fname2); {write the header} Header(@'~_ROOT', $4000, 0); {new desk accessory initialization} if isNewDeskAcc then begin {set up the initial jump table} lab := @'~_ROOT'; menuLen := length(menuLine); RefName(lab, menuLen + dispToOpen, 4, 0); RefName(lab, menuLen + dispToClose, 4, 0); RefName(lab, menuLen + dispToAction, 4, 0); RefName(lab, menuLen + dispToInit, 4, 0); CnOut2(refreshPeriod); CnOut2(eventMask); for i := 1 to menuLen do CnOut(ord(menuLine[i])); CnOut(0); {glue code for calling open routine} CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(openName, 0, 3, 0); CnOut(m_plb); CnOut(m_sta_s); CnOut(4); CnOut(m_txa); CnOut(m_sta_s); CnOut(6); CnOut(m_rtl); {glue code for calling close routine} CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(closeName, 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); {glue code for calling action routine} CnOut(m_phb); SetDataBank; CnOut(m_pha); CnOut(m_phy); CnOut(m_phx); CnOut(m_jsl); RefName(actionName, 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); {glue code for calling init routine} CnOut(m_pha); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_phb); SetDataBank; CnOut(m_pha); CnOut(m_jsl); RefName(initName, 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); end {classic desk accessory initialization} else if isClassicDeskAcc then begin {write the name} menuLen := length(menuLine); CnOut(menuLen); for i := 1 to menuLen do CnOut(ord(menuLine[i])); {set up the initial jump table} lab := @'~_ROOT'; RefName(lab, menuLen + dispToCDAOpen, 4, 0); RefName(lab, menuLen + dispToCDAClose, 4, 0); {glue code for calling open routine} CnOut(m_pea); CnOut2(1); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(@'~CDASTART', 0, 3, 0); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_jsl); RefName(@'~CDASHUTDOWN', 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); {glue code for calling close routine} CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(closeName, 0, 3, 0); CnOut(m_pea); CnOut2(0); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); end {control panel device initialization} else if isCDev then begin CnOut(m_pea); CnOut2(1); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_phb); SetDataBank; CnOut(m_pla); CnOut(m_sta_s); CnOut(13); CnOut(m_pla); CnOut(m_sta_s); CnOut(13); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_tay); CnOut(m_lda_s); CnOut(3); CnOut(m_pha); CnOut(m_lda_s); CnOut(3); CnOut(m_pha); CnOut(m_txa); CnOut(m_sta_s); CnOut(7); CnOut(m_tya); CnOut(m_sta_s); CnOut(5); CnOut(m_plb); CnOut(m_rtl); end {NBA initialization} else if isNBA then begin CnOut(m_jsl); RefName(@'~NBASTARTUP', 0, 3, 0); CnOut(m_phx); CnOut(m_phy); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_jsl); RefName(@'~NBASHUTDOWN', 0, 3, 0); CnOut(m_rtl); end {XCMD initialization} else if isXCMD then begin CnOut(m_jsl); RefName(@'~XCMDSTARTUP', 0, 3, 0); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_jsl); RefName(@'~XCMDSHUTDOWN', 0, 3, 0); CnOut(m_rtl); end {normal program initialization} else begin {write the initial JSL} CnOut(m_jsl); if rtl then RefName(@'~_BWSTARTUP4', 0, 3, 0) else RefName(@'~_BWSTARTUP3', 0, 3, 0); {set the data bank register} SetDataBank; {write JSL to main entry point} CnOut(m_jsl); if rtl then RefName(@'~C_STARTUP2', 0, 3, 0) else RefName(@'~C_STARTUP', 0, 3, 0); CnOut(m_jsl); RefName(@'main', 0, 3, 0); CnOut(m_jsl); if rtl then RefName(@'~C_SHUTDOWN2', 0, 3, 0) else RefName(@'~C_SHUTDOWN', 0, 3, 0); end; {finish the current segment} EndSeg; end; {RootFile} procedure SetStack; { Set up a stack frame } begin {SetStack} if stackSize <> 0 then begin currentSegment := '~_STACK '; {write the header} Header(@'~_STACK', $4012, 0); currentSegment := defaultSegment; Out($F1); {write the DS record to reserve space} Out2(stackSize); Out2(0); EndSeg; {finish the current segment} end; {if} end; {SetStack} begin {InitFile} fname1 := keepname^; if partial or (keepFlag = 3) then FindSuffix(fname1, nextSuffix) else begin if (keepFlag = 1) and (not noroot) then begin RootFile; SetStack; CloseObj; end; {if} DestroySuffixes(fname1); nextSuffix := 'a'; end; {else} fname2.theString.theString := concat(fname1.theString.theString, '.', nextSuffix); fname2.theString.size := length(fname2.theString.theString); OpenObj(fname2); end; {InitFile} procedure InitNative; { set up for a new segment } begin {InitNative} aRegister.condition := regUnknown; {set up the peephole optimizer} xRegister.condition := regUnknown; yRegister.condition := regUnknown; nnextspot := 1; nleadOpcodes := [m_asl_a,m_bcs,m_beq,m_bmi,m_bne,m_bpl,m_brl,m_bvs,m_bcc, m_dec_abs,m_lda_abs,m_lda_dir,m_lda_imm,m_ldx_imm,m_sta_abs,m_sta_dir, m_pha,m_plb,m_plx,m_tax,m_tya,m_tyx,m_phy,m_pei_dir,m_ldy_imm,m_rep, m_ora_dir,m_ora_abs,m_and_imm,m_pea]; nstopOpcodes := [d_end,d_pin]; stringSize := 0; {initialize scalars for a new segment} pc := 0; cbufflen := 0; longA := true; longI := true; end; {InitNative} procedure RefName {lab: stringPtr; disp, len, shift: integer}; { handle a reference to a named label } { } { parameters: } { lab - label name } { disp - displacement past the label } { len - number of bytes in the reference } { shift - shift factor } var i: integer; {loop var} slen: integer; {length of string} begin {RefName} Purge; {clear any constant bytes} if isJSL then {expression header} Out(243) else Out(235); Out(len); Out(131); pc := pc+len; slen := length(lab^); Out(slen); for i := 1 to slen do Out(ord(lab^[i])); if disp <> 0 then begin {if there is a disp, add it in} Out(129); Out2(disp); Out2(0); Out(1); end; {end} if shift <> 0 then begin {if there is a shift, add it in} Out(129); Out2(shift); if shift < 0 then Out2(-1) else Out2(0); Out(7); end; {if} Out(0); {end of expression} end; {RefName} end. {$append 'native.asm'} \ No newline at end of file diff --git a/Native2.pas b/Native2.pas new file mode 100755 index 0000000..71aa9d1 --- /dev/null +++ b/Native2.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ORCA Native Code Generation } { } { This module of the code generator is called to generate } { native code instructions. The native code is optimized } { and written to the object segment. } { } { Externally available procedures: } { } { EndSeg - close out the current segment } { GenNative - write a native code instruction to the output } { file } { GenImplied - short form of GenNative - reduces code size } { GenCall - short form of jsl to library subroutine - reduces } { code size } { GenLab - generate a label } { InitFile - Set up the object file } { InitNative - set up for a new segment } { RefName - handle a reference to a named label } { } {---------------------------------------------------------------} unit Native; interface {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC, ObjOut; {$segment 'CodeGen'} type labelptr = ^labelentry; {pointer to a forward ref node} labelentry = record {forward ref node} addr: integer; next: labelptr; end; labelrec = record {label record} defined: boolean; {Note: form used in objout.asm} chain: labelptr; case boolean of true : (val: longint); false: (ival,hval: integer); end; var {current instruction info} {------------------------} pc: longint; {program counter} {65816 native code generation} {----------------------------} didOne: boolean; {has an optimization been done?} labeltab: array[0..maxlabel] of labelrec; {label table} localLabel: array[0..maxLocalLabel] of integer; {local variable label table} {---------------------------------------------------------------} procedure EndSeg; { close out the current segment } procedure GenNative (p_opcode: integer; p_mode: addressingMode; p_operand: integer; p_name: stringPtr; p_flags: integer); { write a native code instruction to the output file } { } { parameters: } { p_opcode - native op code } { p_mode - addressing mode } { p_operand - integer operand } { p_name - named operand } { p_flags - operand modifier flags } procedure GenImplied (p_opcode: integer); { short form of GenNative - reduces code size } { } { parameters: } { p_code - operation code } procedure GenCall (callNum: integer); { short form of jsl to library subroutine - reduces code size } { } { parameters: } { callNum - subroutine # to generate a call for } procedure GenLab (lnum: integer); { generate a label } { } { parameters: } { lnum - label number } procedure InitFile (keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean); { Set up the object file } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } { } { Note: Declared as extern in CGI.pas } procedure InitNative; { set up for a new segment } procedure LabelSearch (lab: integer; len, shift, disp: integer); { resolve a label reference } { } { parameters: } { lab - label number } { len - # bytes for the generated code } { shift - shift factor } { disp - disp past the label } { } { Note 1: maxlabel is reserved for use as the start of the } { string space } { Note 2: negative length indicates relative branch } { Note 3: zero length indicates 2 byte addr -1 } procedure RefName (lab: stringPtr; disp, len, shift: integer); { handle a reference to a named label } { } { parameters: } { lab - label name } { disp - displacement past the label } { len - number of bytes in the reference } { shift - shift factor } {--------------------------------------------------------------------------} implementation const npeepSize = 128; {native peephole optimizer window size} nMaxPeep = 4; {max # instructions needed to opt.} type {65816 native code generation} {----------------------------} npeepRange = 1..npeepsize; {subrange for native code peephole opt.} nativeType = record {native code instruction} opcode: integer; {op code} mode: addressingMode; {addressing mode} operand: integer; {operand value} name: stringPtr; {operand label} flags: integer; {modifier flags} end; registerConditions = (regUnknown,regImmediate,regAbsolute,regLocal); registerType = record {used to track register contents} condition: registerConditions; value: integer; lab: stringPtr; flags: integer; end; var {I/O files} {---------} fname1, fname2: gsosOutString; {file names} nextSuffix: char; {next suffix character to use} procedure GenSymbols (sym: ptr; doGlobals: integer); extern; { generate the symbol table } {--------------------------------------------------------------------------} procedure LabelSearch {lab: integer; len, shift, disp: integer}; { resolve a label reference } { } { parameters: } { lab - label number } { len - # bytes for the generated code } { shift - shift factor } { disp - disp past the label } { } { Note 1: maxlabel is reserved for use as the start of the } { string space } { Note 2: negative length indicates relative branch } { Note 3: zero length indicates 2 byte addr -1 } var next: labelptr; {work pointer} begin {LabelSearch} if labeltab[lab].defined and (len < 0) and (shift = 0) and (disp = 0) then begin {handle a relative branch to a known disp} if len = -1 then CnOut(labeltab[lab].ival - long(pc).lsw - cbufflen + len) else CnOut2(labeltab[lab].ival - long(pc).lsw - cbufflen + len); end {if} else begin if lab <> maxlabel then begin {handle a normal label reference} Purge; {empty the constant buffer} if len < 0 then begin len := -len; {generate a RELEXPR} Out(238); Out(len); Out2(len); Out2(0); end {if} else begin if isJSL then {generate a standard EXPR} Out(243) else Out(235); if len = 0 then Out(2) else Out(len); end; {else} end; {if} Out(135); {generate a relative offset from the seg. start} if not labeltab[lab].defined then begin next := pointer(Malloc(sizeof(labelEntry))); {value unknown: create a reference} next^.next := labeltab[lab].chain; labeltab[lab].chain := next; next^.addr := blkcnt; Out2(0); Out2(0); end {if} else {labeltab[lab].defined} begin Out2(labeltab[lab].ival); {value known: write it} Out2(labeltab[lab].hval); end; {else} if len = 0 then begin Out(129); {subtract 1 from addr} Out2(1); Out2(0); Out(2); len := 2; end; {if} if disp <> 0 then begin Out(129); {add in the displacement} Out2(disp); if disp < 0 then Out2(-1) else Out2(0); Out(1); end; {if} if shift <> 0 then begin Out(129); {shift the address} Out2(-shift); Out2(-1); Out(7); end; {if} if lab <> maxlabel then {if not a string, end the expression} Out(0); pc := pc+len; {update the pc} end; {else} end; {LabelSearch} procedure UpDate (lab: integer; labelValue: longint); { define a label } { } { parameters: } { lab - label number } { labelValue - displacement in seg where label is located } var next,temp: labelptr; {work pointers} begin {UpDate} if labeltab[lab].defined then Error(cge1) else begin {define the label for future references} with labeltab[lab] do begin defined := true; val := labelValue; next := chain; end; {with} {resolve any forward references} if next <> nil then begin Purge; while next <> nil do begin segdisp := next^.addr; Out2(long(labelvalue).lsw); Out2(long(labelvalue).msw); blkcnt := blkcnt-4; temp := next; next := next^.next; end; {while} segdisp := blkcnt; end; {if} end; {else} end; {UpDate} procedure WriteNative (opcode: integer; mode: addressingMode; operand: integer; name: stringPtr; flags: integer); { write a native code instruction to the output file } { } { parameters: } { opcode - native op code } { mode - addressing mode } { operand - integer operand } { name - named operand } { flags - operand modifier flags } label 1; type rkind = (k1,k2,k3); {cnv record types} var ch: char; {temp storage for string constants} cns: realRec; {for converting reals to bytes} cnv: record {for converting double, real to bytes} case rkind of k1: (rval: real;); k2: (dval: double;); k3: (ival1,ival2,ival3,ival4: integer;); end; count: integer; {number of constants to repeat} i,j,k: integer; {loop variables} lsegDisp: integer; {for backtracking while writting the } { debugger's symbol table } lval: longint; {temp storage for long constant} nptr: stringPtr; {pointer to a name} sptr: longstringPtr; {pointer to a string constant} procedure GenImmediate1; { generate a one byte immediate operand } begin {GenImmediate1} if (flags & stringReference) <> 0 then begin Purge; Out(235); Out(1); {one byte expression} Out(128); {current location ctr} Out(129); Out2(-16); Out2(-1); {-16} Out(7); {bit shift} Out(0); {end of expr} pc := pc+1; end {if} else if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 1, ord(odd(flags div shift16))*16, operand) else if (flags & shift16) <> 0 then RefName(name, operand, 1, -16) else CnOut(operand); end; {GenImmediate1} procedure GenImmediate2; { generate a two byte immediate operand } begin {GenImmediate2} if (flags & stringReference) <> 0 then begin Purge; Out(235); Out(2); LabelSearch(maxLabel, 2, 0, 0); if operand <> 0 then begin Out(129); Out2(operand); Out2(0); Out(1); end; {if} if (flags & shift16) <> 0 then begin Out(129); Out2(-16); Out2(-1); Out(7); end; {if} Out(0); end {if} else if (flags & shift8) <> 0 then RefName(name, operand, 2, -8) else if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 2, ord(odd(flags div shift16))*16, operand) else if (flags & shift16) <> 0 then RefName(name, operand, 2, -16) else if name = nil then CnOut2(operand) else RefName(name, operand, 2, 0); end; {GenImmediate2} procedure DefGlobal (private: integer); { define a global label } { } { parameters: } { private - private flag } var i: integer; {loop variable} begin {DefGlobal} Purge; Out(230); {global label definition} Out(ord(name^[0])); {write label name} for i := 1 to ord(name^[0]) do Out(ord(name^[i])); Out2(0); {length attribute} Out(ord('N')); {type attribute: other directive} Out(private); {private or global?} end; {DefGlobal} begin {WriteNative} { writeln('WriteNative: ',opcode:4, ', mode=', ord(mode):1, ' operand=', operand:1); {debug} case mode of implied: CnOut(opcode); immediate: begin if opcode = d_bmov then GenImmediate1 else begin if opcode = m_and_imm then if not longA then if operand = 255 then goto 1; CnOut(opcode); if opcode = m_pea then GenImmediate2 else if opcode in [m_adc_imm,m_and_imm,m_cmp_imm,m_eor_imm,m_lda_imm,m_ora_imm, m_sbc_imm,m_bit_imm] then if longA then GenImmediate2 else GenImmediate1 else if opcode in [m_rep,m_sep,m_cop] then begin GenImmediate1; if opcode = m_rep then begin if odd(operand div 32) then longA := true; if odd(operand div 16) then longI := true; end {if} else if opcode = m_sep then begin if odd(operand div 32) then longA := false; if odd(operand div 16) then longI := false; end; {else} end {else} else if longI then GenImmediate2 else GenImmediate1; end; {else} end; longabs: begin CnOut(opcode); isJSL := opcode = m_jsl; {allow for dynamic segs} if name = nil then if odd(flags div toolcall) then begin CnOut2(0); CnOut(225); end {if} else LabelSearch(operand, 3, 0, 0) else if odd(flags div toolcall) then begin CnOut2(long(name).lsw); CnOut(long(name).msw); end {if} else RefName(name, operand, 3, 0); isJSL := false; end; longabsolute: begin if opcode <> d_add then begin CnOut(opcode); i := 3; end {if} else i := 4; if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, i, 0, operand) else if (flags & constantOpnd) <> 0 then begin lval := ord4(name); CnOut2(long(lval).lsw); if opcode = d_add then CnOut2(long(lval).msw) else CnOut(long(lval).msw); end {else if} else if name <> nil then RefName(name, operand, i, 0) else begin CnOut2(operand); CnOut(0); if opcode = d_add then CnOut(0); end; {else} end; absolute: begin if opcode <> d_add then CnOut(opcode); if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 2, 0, operand) else if name <> nil then RefName(name, operand, 2, 0) else if (flags & constantOpnd) <> 0 then CnOut2(operand) else LabelSearch(operand, 2, 0, 0); end; direct: begin if opcode <> d_add then CnOut(opcode); if (flags & localLab) <> 0 then LabelSearch(long(name).lsw, 1, 0, operand) else if name <> nil then RefName(name, operand, 1, 0) else CnOut(operand); end; longrelative: begin CnOut(opcode); LabelSearch(operand, -2, 0, 0); end; relative: begin CnOut(opcode); LabelSearch(operand, -1, 0, 0); end; gnrLabel: if name = nil then UpDate(operand, pc+cbufflen) else begin DefGlobal((flags >> 5) & 1); if operand <> 0 then begin Out(241); Out2(operand); Out2(0); pc := pc+operand; end; {if} end; {else} gnrSpace: if operand <> 0 then begin Out(241); Out2(operand); Out2(0); pc := pc+operand; end; {if} gnrConstant: begin if icptr(name)^.optype = cgString then count := 1 else count := icptr(name)^.q; for i := 1 to count do case icptr(name)^.optype of cgByte,cgUByte : CnOut(icptr(name)^.r); cgWord,cgUWord : CnOut2(icptr(name)^.r); cgLong,cgULong : begin lval := icptr(name)^.lval; CnOut2(long(lval).lsw); CnOut2(long(lval).msw); end; cgReal : begin cnv.rval := icptr(name)^.rval; CnOut2(cnv.ival1); CnOut2(cnv.ival2); end; cgDouble : begin cnv.dval := icptr(name)^.rval; CnOut2(cnv.ival1); CnOut2(cnv.ival2); CnOut2(cnv.ival3); CnOut2(cnv.ival4); end; cgComp : begin cns.itsReal := icptr(name)^.rval; CnvSC(cns); for j := 1 to 8 do CnOut(cns.inCOMP[j]); end; cgExtended : begin cns.itsReal := icptr(name)^.rval; CnvSX(cns); for j := 1 to 10 do CnOut(cns.inSANE[j]); end; cgString : begin sptr := icptr(name)^.str; for j := 1 to sptr^.length do CnOut(ord(sPtr^.str[j])); end; ccPointer : begin if icptr(name)^.lab <> nil then begin Purge; Out(235); Out(4); Out(131); pc := pc+4; nptr := icptr(name)^.lab; for j := 0 to ord(nptr^[0]) do Out(ord(nptr^[j])); lval := icptr(name)^.pVal; if lval <> 0 then begin Out(129); Out2(long(lval).lsw); Out2(long(lval).msw); Out(2-icptr(name)^.r); end; {if} Out(0); end {if} else begin lval := icptr(name)^.pVal; if icptr(name)^.r = 1 then operand := stringSize+long(lval).lsw else operand := stringSize-long(lval).lsw; flags := stringReference; GenImmediate2; flags := stringReference+shift16; GenImmediate2; sptr := icptr(name)^.pStr; j := sptr^.length; if maxString-stringSize >= j+1 then begin for k := 1 to j do stringSpace[k+stringSize] := sptr^.str[k]; stringSpace[stringSize+j+1] := chr(0); stringSize := stringSize+j+1; end {if} else Error(cge3); end; {else} end; otherwise : Error(cge1); end; {case} end; genAddress: begin if opcode < 256 then CnOut(opcode); if (flags & stringReference) <> 0 then begin Purge; Out(235); Out(2); LabelSearch(maxLabel,2,0,0); if operand <> 0 then begin Out(129); Out2(operand); Out2(0); Out(1); end; {if} if (flags & shift16) <> 0 then begin Out(129); Out2(-16); Out2(-1); Out(7); end; {if} Out(0); end {if} else if operand = 0 then begin CnOut(0); CnOut(0); end {else if} else if (flags & shift16) <> 0 then if longA then LabelSearch(operand, 2, 16, 0) else LabelSearch(operand, 1, 16, 0) else LabelSearch(operand, 0, 0, 0); end; special: if opcode = d_pin then begin segDisp := 36; out2(long(pc).lsw+cBuffLen); blkCnt := blkCnt-2; segDisp := blkCnt; end {if} else if opcode = d_sym then begin CnOut(m_cop); CnOut(5); Purge; lsegDisp := segDisp+1; CnOut2(0); symLength := 0; GenSymbols(pointer(name), operand); segDisp := lSegDisp; out2(symLength); blkCnt := blkCnt-2; segDisp := blkCnt; end {else if} else {d_wrd} CnOut2(operand); otherwise: Error(cge1); end; {case} 1: end; {WriteNative} {--------------------------------------------------------------------------} procedure EndSeg; { close out the current segment } var i: integer; begin {EndSeg} Purge; {dump constant buffer} if stringsize <> 0 then begin {define string space} UpDate(maxLabel, pc); {define the local label for the string space} for i := 1 to stringsize do CnOut(ord(stringspace[i])); Purge; end; {if} Out(0); {end the segment} segDisp := 8; {update header} Out2(long(pc).lsw); Out2(long(pc).msw); blkcnt := blkcnt-4; {purge the segment to disk} segDisp := blkcnt; CloseSeg; end; {EndSeg} procedure GenNative {p_opcode: integer; p_mode: addressingMode; p_operand: integer; p_name: stringPtr; p_flags: integer}; { write a native code instruction to the output file } { } { parameters: } { p_opcode - native op code } { p_mode - addressing mode } { p_operand - integer operand } { p_name - named operand } { p_flags - operand modifier flags } begin {GenNative} { writeln('GenNative: ',p_opcode:4, ', mode=', ord(p_mode):1, ' operand=', p_operand:1); {debug} if p_opcode <> d_end then WriteNative(p_opcode, p_mode, p_operand, p_name, p_flags); end; {GenNative} procedure GenImplied {p_opcode: integer}; { short form of GenNative - reduces code size } { } { parameters: } { p_code - operation code } begin {GenImplied} GenNative(p_opcode, implied, 0, nil, 0); end; {GenImplied} procedure GenCall {callNum: integer}; { short form of jsl to library subroutine - reduces code size } { } { parameters: } { callNum - subroutine # to generate a call for } var sp: stringPtr; {work string} begin {GenCall} case callNum of 1: sp := @'~CHECKSTACK'; 2: sp := @'~RESETNAME'; 3: sp := @'~CREALRET'; 4: sp := @'~CDOUBLERET'; 5: sp := @'~SETNAME'; 6: sp := @'~SETLINENUMBER'; 7: sp := @'~REALFN'; 8: sp := @'~DOUBLEFN'; 9: sp := @'~SAVEREAL'; 10: sp := @'~SAVEDOUBLE'; 11: sp := @'~CNVINTREAL'; 12: sp := @'~CNVLONGREAL'; 13: sp := @'~CNVULONGREAL'; 14: sp := @'~CNVREALINT'; 15: sp := @'~CNVREALUINT'; 16: sp := @'~CNVREALLONG'; 17: sp := @'~CNVREALULONG'; 18: sp := @'~CNVL2'; {PASCAL} 19: sp := @'~SAVESET'; 20: sp := @'~LOADSET'; {PASCAL} 21: sp := @'~LOADREAL'; 22: sp := @'~LOADDOUBLE'; 23: sp := @'~SHIFTLEFT'; 24: sp := @'~SSHIFTRIGHT'; 25: sp := @'~INTCHKC'; 26: sp := @'~DIV2'; 27: sp := @'~MOD2'; 28: sp := @'~MUL2'; 29: sp := @'~GRTL'; 30: sp := @'~GEQL'; 31: sp := @'~GRTE'; 32: sp := @'~GEQE'; 33: sp := @'~SETINCLUSION'; 34: sp := @'~GRTSTRING'; 35: sp := @'~GEQSTRING'; 36: sp := @'~EQUE'; 37: sp := @'~SETEQU'; 38: sp := @'~EQUSTRING'; 39: sp := @'~UMUL2'; 40: sp := @'~UDIV2'; 41: sp := @'~USHIFTRIGHT'; 42: sp := @'~MUL4'; 43: sp := @'~PDIV4'; 44: sp := @'~MOD4'; 45: sp := @'~SHL4'; 46: sp := @'~LSHR4'; 47: sp := @'~ASHR4'; {CC} 48: sp := @'~UMUL4'; {CC} 49: sp := @'~UDIV4'; {CC} 50: sp := @'~UMOD4'; {CC} 51: sp := @'~COPYREAL'; 52: sp := @'~COPYDOUBLE'; 53: sp := @'~XJPERROR'; 54: sp := @'~MOVE'; 55: sp := @'~MOVE2'; 56: sp := @'~ADDE'; 57: sp := @'~DIVE'; 58: sp := @'~MULE'; 59: sp := @'~SUBE'; 60: sp := @'~POWER'; 61: sp := @'~ARCTAN2E'; 62: sp := @'~LONGMOVE'; 63: sp := @'~LONGMOVE2'; 64: sp := @'~CCOMPRET'; 65: sp := @'~CEXTENDEDRET'; 66: sp := @'~SAVECOMP'; 67: sp := @'~SAVEEXTENDED'; 68: sp := @'~COPYCOMP'; 69: sp := @'~COPYEXTENDED'; 70: sp := @'~LOADCOMP'; 71: sp := @'~LOADEXTENDED'; 72: sp := @'~LOADUBF'; 73: sp := @'~LOADBF'; 74: sp := @'~SAVEBF'; 75: sp := @'~COPYBF'; 76: sp := @'~STACKERR'; {CC} 77: sp := @'~LOADSTRUCT'; {CC} otherwise: Error(cge1); end; {case} GenNative(m_jsl, longabs, 0, sp, 0); end; {GenCall} procedure GenLab {lnum: integer}; { generate a label } { } { parameters: } { lnum - label number } begin {GenLab} GenNative(d_lab, gnrlabel, lnum, nil, 0); end; {GenLab} procedure InitFile {keepName: gsosOutStringPtr; keepFlag: integer; partial: boolean}; { Set up the object file } { } { parameters: } { keepName - name of the output file } { keepFlag - keep status: } { 0 - don't keep the output } { 1 - create a new object module } { 2 - a .root already exists } { 3 - at least on .letter file exists } { partial - is this a partial compile? } { } { Note: Declared as extern in CGI.pas } procedure RootFile; { Create and write the initial entry segment } const dispToOpen = 21; {disps to glue routines for NDAs} dispToClose = 38; dispToAction = 50; dispToInit = 65; dispToCDAOpen = 9; {disps to glue routines for CDAs} dispToCDAClose = 36; var i: integer; {loop index} lab: stringPtr; {for holdling names var pointers} menuLen: integer; {length of the menu name string} procedure SetDataBank; { set up the data bank register } begin {SetDataBank} CnOut(m_pea); RefName(@'~GLOBALS', 0, 2, -8); CnOut(m_plb); CnOut(m_plb); end; {SetDataBank} begin {RootFile} {open the initial object module} fname2.theString.theString := concat(fname1.theString.theString, '.root'); fname2.theString.size := length(fname2.theString.theString); OpenObj(fname2); {write the header} Header(@'~_ROOT', $4000, 0); {new desk accessory initialization} if isNewDeskAcc then begin {set up the initial jump table} lab := @'~_ROOT'; menuLen := length(menuLine); RefName(lab, menuLen + dispToOpen, 4, 0); RefName(lab, menuLen + dispToClose, 4, 0); RefName(lab, menuLen + dispToAction, 4, 0); RefName(lab, menuLen + dispToInit, 4, 0); CnOut2(refreshPeriod); CnOut2(eventMask); for i := 1 to menuLen do CnOut(ord(menuLine[i])); CnOut(0); {glue code for calling open routine} CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(openName, 0, 3, 0); CnOut(m_plb); CnOut(m_sta_s); CnOut(4); CnOut(m_txa); CnOut(m_sta_s); CnOut(6); CnOut(m_rtl); {glue code for calling close routine} CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(closeName, 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); {glue code for calling action routine} CnOut(m_phb); SetDataBank; CnOut(m_pha); CnOut(m_phy); CnOut(m_phx); CnOut(m_jsl); RefName(actionName, 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); {glue code for calling init routine} CnOut(m_pha); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_phb); SetDataBank; CnOut(m_pha); CnOut(m_jsl); RefName(initName, 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); end {classic desk accessory initialization} else if isClassicDeskAcc then begin {write the name} menuLen := length(menuLine); CnOut(menuLen); for i := 1 to menuLen do CnOut(ord(menuLine[i])); {set up the initial jump table} lab := @'~_ROOT'; RefName(lab, menuLen + dispToCDAOpen, 4, 0); RefName(lab, menuLen + dispToCDAClose, 4, 0); {glue code for calling open routine} CnOut(m_pea); CnOut2(1); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(@'~CDASTART', 0, 3, 0); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_jsl); RefName(@'~CDASHUTDOWN', 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); {glue code for calling close routine} CnOut(m_phb); SetDataBank; CnOut(m_jsl); RefName(closeName, 0, 3, 0); CnOut(m_pea); CnOut2(0); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_plb); CnOut(m_rtl); end {control panel device initialization} else if isCDev then begin CnOut(m_pea); CnOut2(1); CnOut(m_jsl); RefName(@'~DAID', 0, 3, 0); CnOut(m_phb); SetDataBank; CnOut(m_pla); CnOut(m_sta_s); CnOut(13); CnOut(m_pla); CnOut(m_sta_s); CnOut(13); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_tay); CnOut(m_lda_s); CnOut(3); CnOut(m_pha); CnOut(m_lda_s); CnOut(3); CnOut(m_pha); CnOut(m_txa); CnOut(m_sta_s); CnOut(7); CnOut(m_tya); CnOut(m_sta_s); CnOut(5); CnOut(m_plb); CnOut(m_rtl); end {NBA initialization} else if isNBA then begin CnOut(m_jsl); RefName(@'~NBASTARTUP', 0, 3, 0); CnOut(m_phx); CnOut(m_phy); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_jsl); RefName(@'~NBASHUTDOWN', 0, 3, 0); CnOut(m_rtl); end {XCMD initialization} else if isXCMD then begin CnOut(m_jsl); RefName(@'~XCMDSTARTUP', 0, 3, 0); CnOut(m_jsl); RefName(openName,0,3,0); CnOut(m_jsl); RefName(@'~XCMDSHUTDOWN', 0, 3, 0); CnOut(m_rtl); end {normal program initialization} else begin {write the initial JSL} CnOut(m_jsl); if rtl then RefName(@'~_BWSTARTUP4', 0, 3, 0) else RefName(@'~_BWSTARTUP3', 0, 3, 0); {set the data bank register} SetDataBank; {write JSL to main entry point} CnOut(m_jsl); if rtl then RefName(@'~C_STARTUP2', 0, 3, 0) else RefName(@'~C_STARTUP', 0, 3, 0); CnOut(m_jsl); RefName(@'main', 0, 3, 0); CnOut(m_jsl); if rtl then RefName(@'~C_SHUTDOWN2', 0, 3, 0) else RefName(@'~C_SHUTDOWN', 0, 3, 0); end; {finish the current segment} EndSeg; end; {RootFile} procedure SetStack; { Set up a stack frame } begin {SetStack} if stackSize <> 0 then begin currentSegment := '~_STACK '; {write the header} Header(@'~_STACK', $4012, 0); currentSegment := defaultSegment; Out($F1); {write the DS record to reserve space} Out2(stackSize); Out2(0); EndSeg; {finish the current segment} end; {if} end; {SetStack} begin {InitFile} fname1 := keepname^; if partial or (keepFlag = 3) then FindSuffix(fname1, nextSuffix) else begin if (keepFlag = 1) and (not noroot) then begin RootFile; SetStack; CloseObj; end; {if} DestroySuffixes(fname1); nextSuffix := 'a'; end; {else} fname2.theString.theString := concat(fname1.theString.theString, '.', nextSuffix); fname2.theString.size := length(fname2.theString.theString); OpenObj(fname2); end; {InitFile} procedure InitNative; { set up for a new segment } begin {InitNative} stringSize := 0; {initialize scalars for a new segment} pc := 0; cbufflen := 0; longA := true; longI := true; end; {InitNative} procedure RefName {lab: stringPtr; disp, len, shift: integer}; { handle a reference to a named label } { } { parameters: } { lab - label name } { disp - displacement past the label } { len - number of bytes in the reference } { shift - shift factor } var i: integer; {loop var} slen: integer; {length of string} begin {RefName} Purge; {clear any constant bytes} if isJSL then {expression header} Out(243) else Out(235); Out(len); Out(131); pc := pc+len; slen := length(lab^); Out(slen); for i := 1 to slen do Out(ord(lab^[i])); if disp <> 0 then begin {if there is a disp, add it in} Out(129); Out2(disp); Out2(0); Out(1); end; {end} if shift <> 0 then begin {if there is a shift, add it in} Out(129); Out2(shift); if shift < 0 then Out2(-1) else Out2(0); Out(7); end; {if} Out(0); {end of expression} end; {RefName} end. \ No newline at end of file diff --git a/ObjOut.asm b/ObjOut.asm new file mode 100755 index 0000000..989a5e3 --- /dev/null +++ b/ObjOut.asm @@ -0,0 +1 @@ + mcopy objout.macros **************************************************************** * * CnOut - write a byte to the constant buffer * * Inputs: * i - byte to write * **************************************************************** * CnOut start maxCBuffLen equ 191 max index into the constant buffer lda cBuffLen if cBuffLen = maxCBuffLen then cmp #maxCBuffLen bne lb1 jsl Purge Purge; lb1 phb cBuff[cBuffLen] := i; plx ply pla phy phx plb ldx cBuffLen short M sta cBuff,X long M inc cBuffLen cBuffLen := cBuffLen+1; rtl end **************************************************************** * * CnOut2 - write a word to the constant buffer * * Inputs: * i - word to write * **************************************************************** * CnOut2 start maxCBuffLen equ 191 max index into the constant buffer lda cBuffLen if cBuffLen+1 >= maxCBuffLen then inc A cmp #maxCBuffLen blt lb1 jsl Purge Purge; lb1 phb cBuff[cBuffLen] := i; plx ply pla phy phx plb ldx cBuffLen sta cBuff,X inx cBuffLen := cBuffLen+2; inx stx cBuffLen rtl end **************************************************************** * * COut - write a code byte to the object file * * Inputs: * b - byte to write (on stack) * **************************************************************** * COut start phb OutByte(b); pla ply plx phy pha plb jsr OutByte inc blkcnt blkcnt := blkcnt+1; inc4 pc pc := pc+1; rtl end **************************************************************** * * Out2 - write a word to the output file * * Inputs: * w - word to write (on stack) * **************************************************************** * Out2 start phb OutWord(w); pla ply plx phy pha plb jsr OutWord inc blkcnt blkcnt := blkcnt+2; inc blkcnt rtl end **************************************************************** * * Out - write a byte to the output file * * Inputs: * b - byte to write (on stack) * **************************************************************** * Out start phb OutByte(b); pla ply plx phy pha plb jsr OutByte inc blkcnt blkcnt := blkcnt+1; rtl end **************************************************************** * * OutByte - write a byte to the object file * * Inputs: * X - byte to write * **************************************************************** * OutByte private lda objLen if objLen+segDisp = buffSize then clc adc segDisp bcc lb2 phx PurgeObjBuffer; jsl PurgeObjBuffer plx lda objLen check for segment overflow clc adc segDisp bcs lb2a lb2 ph4 objPtr p := pointer(ord4(objPtr)+segDisp); tsc p^ := b; phd tcd ldy segDisp short M txa sta [1],Y long M inc segDisp segDisp := segDisp+1; pld tsc clc adc #4 tcs rts lb2a lda #$8000 handle a segment overflow sta segDisp ph2 #112 jsl Error rts end **************************************************************** * * OutWord - write a word to the object file * * Inputs: * X - word to write * **************************************************************** * OutWord private lda objLen if objLen+segDisp+1 = buffSize then sec adc segDisp bcc lb2 phx PurgeObjBuffer; jsl PurgeObjBuffer plx lda objLen check for segment overflow sec adc segDisp bcs lb3 lb2 ph4 objPtr p := pointer(ord4(objPtr)+segDisp); tsc p^ := b; phd tcd ldy segDisp txa sta [1],Y iny segDisp := segDisp+2; iny sty segDisp save new segDisp pld tsc clc adc #4 tcs rts lb3 ph2 #112 flag segment overflow error jsl Error lda #$8000 sta segDisp rts end \ No newline at end of file diff --git a/ObjOut.macros b/ObjOut.macros new file mode 100755 index 0000000..e704a43 --- /dev/null +++ b/ObjOut.macros @@ -0,0 +1 @@ + MACRO &LAB LONG &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB REP #&M*32+&I*16 AIF .NOT.&M,.B LONGA ON .B AIF .NOT.&I,.C LONGI ON .C MEND MACRO &LAB PH4 &N1 LCLC &C &LAB ANOP &C AMID &N1,1,1 AIF "&C"="#",.D AIF S:LONGA=1,.A REP #%00100000 .A AIF "&C"<>"{",.B &C AMID &N1,L:&N1,1 AIF "&C"<>"}",.G &N1 AMID &N1,2,L:&N1-2 LDY #2 LDA (&N1),Y PHA LDA (&N1) PHA AGO .E .B AIF "&C"<>"[",.C LDY #2 LDA &N1,Y PHA LDA &N1 PHA AGO .E .C LDA &N1+2 PHA LDA &N1 PHA AGO .E .D &N1 AMID &N1,2,L:&N1-1 PEA +(&N1)|-16 PEA &N1 AGO .F .E AIF S:LONGA=1,.F SEP #%00100000 .F MEXIT .G MNOTE "Missing closing '}'",16 MEND MACRO &LAB SHORT &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB SEP #&M*32+&I*16 AIF .NOT.&M,.B LONGA OFF .B AIF .NOT.&I,.C LONGI OFF .C MEND MACRO &LAB INC4 &A &LAB ~SETM INC &A BNE ~&SYSCNT INC 2+&A ~&SYSCNT ~RESTM MEND MACRO &LAB ~SETM &LAB ANOP AIF C:&~LA,.B GBLB &~LA GBLB &~LI .B &~LA SETB S:LONGA &~LI SETB S:LONGI AIF S:LONGA.AND.S:LONGI,.A REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) LONGA ON LONGI ON .A MEND MACRO &LAB ~RESTM &LAB ANOP AIF (&~LA+&~LI)=2,.I SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) AIF &~LA,.H LONGA OFF .H AIF &~LI,.I LONGI OFF .I MEND MACRO &LAB PUT2 &N1,&F1,&CR,&ERROUT AIF C:&F1,.A LCLC &F1 &F1 SETC #0 .A &LAB ~SETM PH2 &N1 PH2 &F1 PH2 #C:&CR PH2 #C:&ERROUT JSL ~PUT2 ~RESTM MEND MACRO &LAB PUT4 &N1,&F1,&CR,&ERROUT AIF C:&F1,.A LCLC &F1 &F1 SETC #0 .A &LAB ~SETM PH4 &N1 PH2 &F1 PH2 #C:&CR PH2 #C:&ERROUT JSL ~PUT4 ~RESTM MEND MACRO &LAB PUTS &N1,&F1,&CR,&ERROUT &LAB ~SETM LCLC &C &C AMID "&N1",1,1 AIF "&C"<>"#",.C AIF L:&N1>127,.A BRA ~&SYSCNT AGO .B .A BRL ~&SYSCNT .B &N1 AMID "&N1",2,L:&N1-1 ~L&SYSCNT DC I1"L:~S&SYSCNT" ~S&SYSCNT DC C&N1 ~&SYSCNT ANOP &N1 SETC ~L&SYSCNT-1 AIF C:&F1=0,.D .C ~PUSHA &N1 AIF C:&F1,.C1 PEA 0 AGO .C2 .C1 PH2 &F1 .C2 PH2 #C:&CR PH2 #C:&ERROUT JSL ~PUTS ~RESTM MEXIT .D PEA ~L&SYSCNT|-16 PEA ~L&SYSCNT LDX #$1C0C+(C:&ERROUT*256)-(512*C:&CR) JSL $E10000 ~RESTM MEND MACRO &LAB ~PUSHA &N1 LCLC &C &LAB ANOP &C AMID &N1,1,1 AIF "&C"<>"{",.B &C AMID &N1,L:&N1,1 AIF "&C"<>"}",.G &N1 AMID &N1,2,L:&N1-2 SEP #$20 LONGA OFF LDA #0 PHA REP #$20 LONGA ON PHK LDA &N1 PHA MEXIT .B AIF "&C"<>"[",.C &N1 AMID &N1,2,L:&N1-2 LDA &N1+2 PHA LDA &N1 PHA MEXIT .C PEA +(&N1)|-16 PEA &N1 MEXIT .G MNOTE "Missing closing '}'",16 MEND MACRO &LAB PH2 &N1 LCLC &C &LAB ANOP &C AMID &N1,1,1 AIF "&C"="#",.D AIF S:LONGA=1,.A REP #%00100000 .A AIF "&C"<>"{",.B &C AMID &N1,L:&N1,1 AIF "&C"<>"}",.G &N1 AMID &N1,2,L:&N1-2 LDA (&N1) PHA AGO .E .B LDA &N1 PHA AGO .E .D &N1 AMID &N1,2,L:&N1-1 PEA &N1 AGO .F .E AIF S:LONGA=1,.F SEP #%00100000 .F MEXIT .G MNOTE "Missing closing '}'",16 MEND \ No newline at end of file diff --git a/ObjOut.pas b/ObjOut.pas new file mode 100755 index 0000000..0f49044 --- /dev/null +++ b/ObjOut.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ObjOut } { } { This unit has the primitive routines used to actually } { create and write to object modules. A few low-level } { subroutines that need to be in assembly language for speed } { are also included here. } { } { External Subroutines: } { } { CloseObj - close the current obj file } { CloseSeg - close out the current segment } { COut - write a code byte to the object file } { CnOut - write a byte to the constant buffer } { CnOut2 - write a word to the constant buffer } { DestroySuffixes - destroy the .a, .b, etc suffixes } { FindSuffix - find the next available alphabetic suffix } { Header - write a segment header to the output file } { OpenObj - open a new obj file with the indicated file name } { OpenSeg - create a new segment and mark its beginning } { Out - write a byte to the output file } { Out2 - write a word to the output file } { Purge - write any constant bytes to the output buffer } { } {---------------------------------------------------------------} unit CCommon; interface {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC; {$segment 'CodeGen'} procedure CloseObj; { close the current obj file } { } { Note: Declared as extern in CGI.pas } procedure COut (b: integer); extern; { write a code byte to the object file } { } { parameters: } { b - byte to write } procedure CnOut (i: integer); extern; { write a byte to the constant buffer } { } { parameters: } { i - byte to write } procedure CnOut2 (i: integer); extern; { write a word to the constant buffer } { } { parameters: } { i - word to write } procedure DestroySuffixes (var name: gsosOutString); { destroy the .a, .b, etc suffixes } { } { parameters: } { name - root name of file sequence to destroy } procedure CloseSeg; { close out the current segment } procedure FindSuffix (var name: gsosOutString; var ch: char); { find the next available alphabetic suffix } { } { parameters: } { ch - addr to place suffix character } { name - root name of suffix to find } procedure Header (name: stringPtr; kind: integer; lengthCode: integer); { write a segment header to the output file } { } { parameters: } { name - name of the segment } { kind - segment kind } { lengthCode - code bank size code; bank size div $10000 } procedure OpenSeg; { create a new segment and mark its beginning } procedure OpenObj (var name: gsosOutString); { open a new obj file with the indicated file name } { } { parameters: } { name - object file name } procedure Out (b: integer); extern; { write a byte to the output file } { } { parameters: } { b - byte to write } procedure Out2 (w: integer); extern; { write a word to the output file } { } { parameters: } { w - word to write } procedure Purge; { write any constant bytes to the output buffer } {---------------------------------------------------------------} implementation const {NOTE: OutByte and Outword assume } { buffSize is 64K } buffSize = 65536; {size of the obj buffer} maxCBuffLen = 191; {length of the constant buffer} OBJ = $B1; {object file type} type closeOSDCB = record {Close DCB} pcount: integer; refNum: integer; end; createOSDCB = record {Create DCB} pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; dataEOF: longint; resourceEOF: longint; end; destroyOSDCB = record {Destroy DCB} pcount: integer; pathName: gsosInStringPtr; end; getFileInfoOSDCB = record {GetFileInfo DCB} pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; openOSDCB = record {Open DCB} pcount: integer; refNum: integer; pathName: gsosInStringPtr; requestAccess: integer; resourceNumber: integer; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; readWriteOSDCB = record {WriteGS DCB} pcount: integer; refNum: integer; dataBuffer: ptr; requestCount: longint; transferCount: longint; cachePriority: integer; end; {---------------------------------------------------------------} var cBuff: array[0..maxCBuffLen] of byte; {constant buffer} objLen: longint; {# bytes used in obj buffer} objHandle: handle; {handle of the obj buffer} objPtr: ptr; {pointer to the next spot in the obj buffer} segStart: ptr; {points to first byte in current segment} spoolRefnum: integer; {reference number for open file} {---------------------------------------------------------------} {memory manager calls} {--------------------} procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B); function NewHandle (blockSize: longint; userID, memAttributes: integer; memLocation: ptr): handle; tool($02, $09); procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19); procedure HUnLock (theHandle: handle); tool ($02, $22); procedure HLock (theHandle: handle); tool ($02, $20); {ProDOS calls} {------------} procedure CloseGS (var parms: closeOSDCB); prodos ($2014); procedure CreateGS (var parms: createOSDCB); prodos ($2001); procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002); procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006); procedure OpenGS (var parms: openOSDCB); prodos ($2010); procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013); {---------------------------------------------------------------} procedure PurgeObjBuffer; { Spool any completed segments to the object file } var len: longint; {# bytes to write} sPtr: ptr; {start of object buffer} wrRec: readWriteOSDCB; {WriteGS record} procedure InitSpoolFile; { Set up the spool file } var dsRec: destroyOSDCB; {DestroyGS record} crRec: createOSDCB; {CreateGS record} opRec: openOSDCB; {OpenGS record} begin {InitSpoolFile} if memoryCompile then {make sure this is a disk-based compile} TermError(11); dsRec.pCount := 1; {destroy any old file} dsRec.pathname := @objFile.theString; DestroyGS(dsRec); crRec.pCount := 5; {create a new file} crRec.pathName := @objFile.theString; crRec.access := $C3; crRec.fileType := OBJ; crRec.auxType := $0000; crRec.storageType := 1; CreateGS(crRec); if ToolError <> 0 then TermError(9); opRec.pCount := 3; {open the file} opRec.pathname := @objFile.theString; opRec.requestAccess := 3; OpenGS(opRec); if ToolError <> 0 then TermError(9); spoolRefnum := opRec.refnum; end; {InitSpoolFile} begin {PurgeObjBuffer} if spoolRefnum = 0 then {make sure the spool file exists} InitSpoolFile; sPtr := objHandle^; {determine size of completed segments} len := ord4(segStart) - ord4(sPtr); if len <> 0 then begin wrRec.pcount := 4; {write completed segments} wrRec.refnum := spoolRefnum; wrRec.dataBuffer := pointer(sPtr); wrRec.requestCount := len; WriteGS(wrRec); if ToolError <> 0 then {check for write errors} TermError(9); objLen := 0; {adjust file pointers} BlockMove(segStart, sPtr, ord4(segDisp) & $00FFFF); objPtr := sPtr; segStart := sPtr; end; {if} end; {PurgeObjBuffer} {---------------------------------------------------------------} procedure CloseObj; { close the current obj file } { } { Note: Declared as extern in CGI.pas } var clRec: closeOSDCB; {CloseGS record} ffDCBGS: fastFileDCBGS; {dcb for fastfile call} i: integer; {loop/index variable} begin {CloseObj} if spoolRefnum <> 0 then begin PurgeObjBuffer; clRec.pCount := 1; clRec.refnum := spoolRefnum; CloseGS(clRec); end {if} else if objLen <> 0 then begin {resize the buffer} HUnLock(objHandle); SetHandleSize(objLen, objHandle); HLock(objHandle); {save the file} ffDCBGS.pCount := 14; ffDCBGS.fileHandle := objHandle; ffDCBGS.pathName := @objFile.theString; ffDCBGS.access := $C3; ffDCBGS.fileType := OBJ; ffDCBGS.auxType := 0; ffDCBGS.storageType := 1; for i := 1 to 8 do ffDCBGS.createDate[i] := 0; ffDCBGS.modDate := ffDCBGS.createDate; ffDCBGS.option := nil; ffDCBGS.fileLength := objLen; if memoryCompile then begin ffDCBGS.flags := 0; ffDCBGS.action := 4; end {if} else begin ffDCBGS.flags := $C000; ffDCBGS.action := 3; end; {else} FastFileGS(ffDCBGS); if ToolError <> 0 then TermError(9) else begin ffDCBGS.PATHName := @objFile.theString; ffDCBGS.action := 7; FastFileGS(ffDCBGS); end; {else} end; {if} end; {CloseObj} procedure DestroySuffixes {var name: gsosOutString}; { destroy the .a, .b, etc suffixes } { } { parameters: } { name - root name of file sequence to destroy } var done: boolean; {loop termination flag} dsDCBGS: destroyOSDCB; {dcb for destroy call} giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call} suffix: char; {current suffix character} fName: gsosInString; {work file name} begin {DestroySuffixes} suffix := 'a'; done := false; repeat fName := name.theString; if fName.size > maxPath-2 then fName.size := maxPath-2; fName.theString[fName.size+1] := '.'; fName.theString[fName.size+2] := suffix; fName.size := fName.size + 2; giDCBGS.pCount := 12; giDCBGS.optionList := nil; giDCBGS.pathName := @fName; GetFileInfoGS(giDCBGS); if ToolError = 0 then begin if giDCBGS.fileType = OBJ then begin dsDCBGS.pCount := 1; dsDCBGS.pathName := @fName; DestroyGS(dsDCBGS); end; {if} end {if} else done := true; suffix := succ(suffix); until done; end; {DestroySuffixes} procedure CloseSeg; { close out the current segment } { } { variables: } { objHandle - segment handle } { objLen - used bytes in the segment } { objPtr - set to point to a fresh segment } var longPtr: ^longint; {used to set the block count} begin {CloseSeg} longPtr := pointer(objPtr); {set the block count} longPtr^ := ord4(segDisp) & $00FFFF; objLen := objLen + (ord4(segDisp) & $00FFFF); {update the length of the obj file} objPtr := pointer(ord4(objHandle^)+objLen); {set objPtr} segStart := objPtr; if objLen = buffSize then PurgeObjBuffer; end; {CloseSeg} procedure FindSuffix {var name: gsosOutString; var ch: char}; { find the next available alphabetic suffix } { } { parameters: } { ch - addr to place suffix character } { name - root name of suffix to find } var done: boolean; {loop termination test} giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call} fName: gsosInString; {work file name} begin {FindSuffix} ch := 'a'; done := false; repeat fName := name.theString; if fName.size > maxPath-2 then fName.size := maxPath-2; fName.theString[fName.size+1] := '.'; fName.theString[fName.size+2] := ch; fName.size := fName.size + 2; giDCBGS.pCount := 12; giDCBGS.optionList := nil; giDCBGS.pathName := @fName; GetFileInfoGS(giDCBGS); if ToolError = 0 then ch := succ(ch) else done := true; until done; end; {FindSuffix} procedure Header {name: stringPtr; kind: integer; lengthCode: integer}; { write a segment header to the output file } { } { parameters: } { name - name of the segment } { kind - segment kind } { lengthCode - code bank size code; bank size div $10000 } var i: integer; {loop var} len: integer; {length of string} begin {Header} OpenSeg; {start the new segment} blkcnt := 0; segdisp := 0; for i := 1 to 12 do {blkcnt,resspc,length} Out(0); Out(0); {unused} Out(0); {lablen} Out(4); {numlen} Out(2); {version} Out2(0); Out2(ord(lengthcode=0)); {cbanksize} Out2(kind|segmentKind); {kind} for i := 1 to 9 do {unused,org,align,numsex,unused,segnum,entry} Out2(0); len := length(name^); {dispname,dispdata} Out2($30); Out2($3B+len); Out2(0); Out2(0); {temporg} for i := 1 to 10 do {write the segment name} Out(ord(currentSegment[i])); currentSegment := defaultSegment; {revert to default segment name} Out(len); {segname} for i := 1 to len do Out(ord(name^[i])); end; {Header} procedure OpenSeg; { create a new segment and mark its beginning } begin {OpenSeg} segDisp := 0; segStart := objPtr; end; {OpenSeg} procedure OpenObj {var name: gsosOutString}; { open a new obj file with the indicated file name } { } { parameters: } { name - object file name } var dsDCBGS: destroyOSDCB; {dcb for Destroy call} giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call} begin {OpenObj} {the file is not spooled (yet)} spoolRefnum := 0; {if there is an existing file, delete it} if memoryCompile then begin giDCBGS.pCount := 3; giDCBGS.pathName := @name.theString; GetFileInfoGS(giDCBGS); if ToolError = 0 then if giDCBGS.fileType = OBJ then begin dsDCBGS.pCount := 1; dsDCBGS.pathName := @name.theString; DestroyGS(dsDCBGS); end; {if} end; {if} {allocate memory for an initial buffer} objHandle := pointer(NewHandle(buffSize, userID, $8000, nil)); {set up the buffer variables} if ToolError = 0 then begin objLen := 0; objPtr := objHandle^; end {if} else TermError(5); {save the object file name} objFile := name; end; {OpenObj} procedure Purge; { write any constant bytes to the output buffer } var i: integer; {loop variable} begin {Purge} if cBuffLen <> 0 then begin Out(cBuffLen); for i := 0 to cBuffLen-1 do COut(cBuff[i]); cBuffLen := 0; end; {if} end; {Purge} end. {$append 'objout.asm'} \ No newline at end of file diff --git a/ObjOut2.asm b/ObjOut2.asm new file mode 100755 index 0000000..75b3a8e --- /dev/null +++ b/ObjOut2.asm @@ -0,0 +1 @@ + mcopy objout.macros **************************************************************** * * CnOut - write a byte to the constant buffer * * Inputs: * i - byte to write * **************************************************************** * CnOut start maxCBuffLen equ 191 max index into the constant buffer lda cBuffLen if cBuffLen = maxCBuffLen then cmp #maxCBuffLen bne lb1 jsl Purge Purge; lb1 phb cBuff[cBuffLen] := i; plx ply pla phy phx plb ldx cBuffLen short M sta cBuff,X long M inc cBuffLen cBuffLen := cBuffLen+1; rtl end **************************************************************** * * CnOut2 - write a word to the constant buffer * * Inputs: * i - word to write * **************************************************************** * CnOut2 start maxCBuffLen equ 191 max index into the constant buffer lda cBuffLen if cBuffLen+1 >= maxCBuffLen then inc A cmp #maxCBuffLen blt lb1 jsl Purge Purge; lb1 phb cBuff[cBuffLen] := i; plx ply pla phy phx plb ldx cBuffLen sta cBuff,X inx cBuffLen := cBuffLen+2; inx stx cBuffLen rtl end **************************************************************** * * COut - write a code byte to the object file * * Inputs: * b - byte to write (on stack) * **************************************************************** * COut start phb OutByte(b); pla ply plx phy pha plb jsr OutByte inc blkcnt blkcnt := blkcnt+1; inc4 pc pc := pc+1; rtl end **************************************************************** * * Out2 - write a word to the output file * * Inputs: * w - word to write (on stack) * **************************************************************** * Out2 start phb OutWord(w); pla ply plx phy pha plb jsr OutWord inc blkcnt blkcnt := blkcnt+2; inc blkcnt rtl end **************************************************************** * * Out - write a byte to the output file * * Inputs: * b - byte to write (on stack) * **************************************************************** * Out start phb OutByte(b); pla ply plx phy pha plb jsr OutByte inc blkcnt blkcnt := blkcnt+1; rtl end **************************************************************** * * OutByte - write a byte to the object file * * Inputs: * X - byte to write * **************************************************************** * OutByte private buffSize equ 16384 buffer size lda objLen if objLen+segDisp+1 = buffSize then sec adc segDisp cmp #buffSize blt lb2 phx PurgeObjBuffer; jsl PurgeObjBuffer plx lda objLen check for segment overflow sec adc segDisp cmp #buffSize bge lb2a lb2 ph4 objPtr p := pointer(ord4(objPtr)+segDisp); tsc p^ := b; phd tcd ldy segDisp short M txa sta [1],Y long M inc segDisp segDisp := segDisp+1; pld tsc clc adc #4 tcs rts lb2a lda #$1000 handle a segment buffer overflow sta segDisp ph2 #112 jsl Error rts end **************************************************************** * * OutWord - write a word to the object file * * Inputs: * X - word to write * **************************************************************** * OutWord private buffSize equ 16384 buffer size lda objLen if objLen+segDisp+2 = buffSize then sec adc segDisp cmp #buffSize-1 blt lb2 phx PurgeObjBuffer; jsl PurgeObjBuffer plx lda objLen check for segment overflow sec adc segDisp cmp #buffSize-1 bge lb3 lb2 ph4 objPtr p := pointer(ord4(objPtr)+segDisp); tsc p^ := b; phd tcd ldy segDisp txa sta [1],Y iny segDisp := segDisp+2; iny sty segDisp pld tsc clc adc #4 tcs rts lb3 ph2 #112 flag segment overflow error jsl Error lda #$1000 sta segDisp rts end \ No newline at end of file diff --git a/ObjOut2.pas b/ObjOut2.pas new file mode 100755 index 0000000..7d63ace --- /dev/null +++ b/ObjOut2.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { ObjOut } { } { This unit has the primitive routines used to actually } { create and write to object modules. A few low-level } { subroutines that need to be in assembly language for speed } { are also included here. } { } { External Subroutines: } { } { CloseObj - close the current obj file } { CloseSeg - close out the current segment } { COut - write a code byte to the object file } { CnOut - write a byte to the constant buffer } { CnOut2 - write a word to the constant buffer } { DestroySuffixes - destroy the .a, .b, etc suffixes } { FindSuffix - find the next available alphabetic suffix } { Header - write a segment header to the output file } { OpenObj - open a new obj file with the indicated file name } { OpenSeg - create a new segment and mark its beginning } { Out - write a byte to the output file } { Out2 - write a word to the output file } { Purge - write any constant bytes to the output buffer } { } {---------------------------------------------------------------} unit CCommon; interface {$LibPrefix '0/obj/'} uses CCommon, CGI, CGC; {$segment 'CodeGen'} procedure CloseObj; { close the current obj file } { } { Note: Declared as extern in CGI.pas } procedure COut (b: integer); extern; { write a code byte to the object file } { } { parameters: } { b - byte to write } procedure CnOut (i: integer); extern; { write a byte to the constant buffer } { } { parameters: } { i - byte to write } procedure CnOut2 (i: integer); extern; { write a word to the constant buffer } { } { parameters: } { i - word to write } procedure DestroySuffixes (var name: gsosOutString); { destroy the .a, .b, etc suffixes } { } { parameters: } { name - root name of file sequence to destroy } procedure CloseSeg; { close out the current segment } procedure FindSuffix (var name: gsosOutString; var ch: char); { find the next available alphabetic suffix } { } { parameters: } { ch - addr to place suffix character } { name - root name of suffix to find } procedure Header (name: stringPtr; kind: integer; lengthCode: integer); { write a segment header to the output file } { } { parameters: } { name - name of the segment } { kind - segment kind } { lengthCode - code bank size code; bank size div $10000 } procedure OpenSeg; { create a new segment and mark its beginning } procedure OpenObj (var name: gsosOutString); { open a new obj file with the indicated file name } { } { parameters: } { name - object file name } procedure Out (b: integer); extern; { write a byte to the output file } { } { parameters: } { b - byte to write } procedure Out2 (w: integer); extern; { write a word to the output file } { } { parameters: } { w - word to write } procedure Purge; { write any constant bytes to the output buffer } {---------------------------------------------------------------} implementation const {NOTE: OutByte and Outword assume } { buffSize is 16K } buffSize = 16384; {size of the obj buffer} maxCBuffLen = 191; {length of the constant buffer} OBJ = $B1; {object file type} type closeOSDCB = record {Close DCB} pcount: integer; refNum: integer; end; createOSDCB = record {Create DCB} pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; dataEOF: longint; resourceEOF: longint; end; destroyOSDCB = record {Destroy DCB} pcount: integer; pathName: gsosInStringPtr; end; getFileInfoOSDCB = record {GetFileInfo DCB} pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; openOSDCB = record {Open DCB} pcount: integer; refNum: integer; pathName: gsosInStringPtr; requestAccess: integer; resourceNumber: integer; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; readWriteOSDCB = record {WriteGS DCB} pcount: integer; refNum: integer; dataBuffer: ptr; requestCount: longint; transferCount: longint; cachePriority: integer; end; {---------------------------------------------------------------} var cBuff: array[0..maxCBuffLen] of byte; {constant buffer} objLen: longint; {# bytes used in obj buffer} objHandle: handle; {handle of the obj buffer} objPtr: ptr; {pointer to the next spot in the obj buffer} segStart: ptr; {points to first byte in current segment} spoolRefnum: integer; {reference number for open file} {---------------------------------------------------------------} {memory manager calls} {--------------------} procedure BlockMove (sourcPtr, destPtr: ptr; count: longint); tool ($02, $2B); function NewHandle (blockSize: longint; userID, memAttributes: integer; memLocation: ptr): handle; tool($02, $09); procedure SetHandleSize (newSize: longint; theHandle: handle); tool ($02, $19); procedure HUnLock (theHandle: handle); tool ($02, $22); procedure HLock (theHandle: handle); tool ($02, $20); {ProDOS calls} {------------} procedure CloseGS (var parms: closeOSDCB); prodos ($2014); procedure CreateGS (var parms: createOSDCB); prodos ($2001); procedure DestroyGS (var parms: destroyOSDCB); prodos ($2002); procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006); procedure OpenGS (var parms: openOSDCB); prodos ($2010); procedure WriteGS (var parms: readWriteOSDCB); prodos ($2013); {---------------------------------------------------------------} procedure PurgeObjBuffer; { Spool any completed segments to the object file } var len: longint; {# bytes to write} sPtr: ptr; {start of object buffer} wrRec: readWriteOSDCB; {WriteGS record} procedure InitSpoolFile; { Set up the spool file } var dsRec: destroyOSDCB; {DestroyGS record} crRec: createOSDCB; {CreateGS record} opRec: openOSDCB; {OpenGS record} begin {InitSpoolFile} if memoryCompile then {make sure this is a disk-based compile} TermError(11); dsRec.pCount := 1; {destroy any old file} dsRec.pathname := @objFile.theString; DestroyGS(dsRec); crRec.pCount := 5; {create a new file} crRec.pathName := @objFile.theString; crRec.access := $C3; crRec.fileType := OBJ; crRec.auxType := $0000; crRec.storageType := 1; CreateGS(crRec); if ToolError <> 0 then TermError(9); opRec.pCount := 3; {open the file} opRec.pathname := @objFile.theString; opRec.requestAccess := 3; OpenGS(opRec); if ToolError <> 0 then TermError(9); spoolRefnum := opRec.refnum; end; {InitSpoolFile} begin {PurgeObjBuffer} if spoolRefnum = 0 then {make sure the spool file exists} InitSpoolFile; sPtr := objHandle^; {determine size of completed segments} len := ord4(segStart) - ord4(sPtr); if len <> 0 then begin wrRec.pcount := 4; {write completed segments} wrRec.refnum := spoolRefnum; wrRec.dataBuffer := pointer(sPtr); wrRec.requestCount := len; WriteGS(wrRec); if ToolError <> 0 then {check for write errors} TermError(9); objLen := 0; {adjust file pointers} BlockMove(segStart, sPtr, segDisp); objPtr := sPtr; segStart := sPtr; end; {if} end; {PurgeObjBuffer} {---------------------------------------------------------------} procedure CloseObj; { close the current obj file } { } { Note: Declared as extern in CGI.pas } var clRec: closeOSDCB; {CloseGS record} ffDCBGS: fastFileDCBGS; {dcb for fastfile call} i: integer; {loop/index variable} begin {CloseObj} if spoolRefnum <> 0 then begin PurgeObjBuffer; clRec.pCount := 1; clRec.refnum := spoolRefnum; CloseGS(clRec); end {if} else if objLen <> 0 then begin {resize the buffer} HUnLock(objHandle); SetHandleSize(objLen, objHandle); HLock(objHandle); {save the file} ffDCBGS.pCount := 14; ffDCBGS.fileHandle := objHandle; ffDCBGS.pathName := @objFile.theString; ffDCBGS.access := $C3; ffDCBGS.fileType := OBJ; ffDCBGS.auxType := 0; ffDCBGS.storageType := 1; for i := 1 to 8 do ffDCBGS.createDate[i] := 0; ffDCBGS.modDate := ffDCBGS.createDate; ffDCBGS.option := nil; ffDCBGS.fileLength := objLen; if memoryCompile then begin ffDCBGS.flags := 0; ffDCBGS.action := 4; end {if} else begin ffDCBGS.flags := $C000; ffDCBGS.action := 3; end; {else} FastFileGS(ffDCBGS); if ToolError <> 0 then TermError(9) else begin ffDCBGS.PATHName := @objFile.theString; ffDCBGS.action := 7; FastFileGS(ffDCBGS); end; {else} end; {if} end; {CloseObj} procedure DestroySuffixes {var name: gsosOutString}; { destroy the .a, .b, etc suffixes } { } { parameters: } { name - root name of file sequence to destroy } var done: boolean; {loop termination flag} dsDCBGS: destroyOSDCB; {dcb for destroy call} giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call} suffix: char; {current suffix character} fName: gsosInString; {work file name} begin {DestroySuffixes} suffix := 'a'; done := false; repeat fName := name.theString; if fName.size > maxPath-2 then fName.size := maxPath-2; fName.theString[fName.size+1] := '.'; fName.theString[fName.size+2] := suffix; fName.size := fName.size + 2; giDCBGS.pCount := 12; giDCBGS.optionList := nil; giDCBGS.pathName := @fName; GetFileInfoGS(giDCBGS); if ToolError = 0 then begin if giDCBGS.fileType = OBJ then begin dsDCBGS.pCount := 1; dsDCBGS.pathName := @fName; DestroyGS(dsDCBGS); end; {if} end {if} else done := true; suffix := succ(suffix); until done; end; {DestroySuffixes} procedure CloseSeg; { close out the current segment } { } { variables: } { objHandle - segment handle } { objLen - used bytes in the segment } { objPtr - set to point to a fresh segment } var longPtr: ^longint; {used to set the block count} begin {CloseSeg} longPtr := pointer(objPtr); {set the block count} longPtr^ := segDisp; objLen := objLen + segDisp; {update the length of the obj file} objPtr := pointer(ord4(objHandle^)+objLen); {set objPtr} segStart := objPtr; if objLen = buffSize then PurgeObjBuffer; end; {CloseSeg} procedure FindSuffix {var name: gsosOutString; var ch: char}; { find the next available alphabetic suffix } { } { parameters: } { ch - addr to place suffix character } { name - root name of suffix to find } var done: boolean; {loop termination test} giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call} fName: gsosInString; {work file name} begin {FindSuffix} ch := 'a'; done := false; repeat fName := name.theString; if fName.size > maxPath-2 then fName.size := maxPath-2; fName.theString[fName.size+1] := '.'; fName.theString[fName.size+2] := ch; fName.size := fName.size + 2; giDCBGS.pCount := 12; giDCBGS.optionList := nil; giDCBGS.pathName := @fName; GetFileInfoGS(giDCBGS); if ToolError = 0 then ch := succ(ch) else done := true; until done; end; {FindSuffix} procedure Header {name: stringPtr; kind: integer; lengthCode: integer}; { write a segment header to the output file } { } { parameters: } { name - name of the segment } { kind - segment kind } { lengthCode - code bank size code; bank size div $10000 } var i: integer; {loop var} len: integer; {length of string} begin {Header} OpenSeg; {start the new segment} blkcnt := 0; segdisp := 0; for i := 1 to 12 do {blkcnt,resspc,length} Out(0); Out(0); {unused} Out(0); {lablen} Out(4); {numlen} Out(2); {version} Out2(0); Out2(ord(lengthcode=0)); {cbanksize} Out2(kind|segmentKind); {kind} for i := 1 to 9 do {unused,org,align,numsex,unused,segnum,entry} Out2(0); len := length(name^); {dispname,dispdata} Out2($30); Out2($3B+len); Out2(0); Out2(0); {temporg} for i := 1 to 10 do {write the segment name} Out(ord(currentSegment[i])); currentSegment := defaultSegment; {revert to default segment name} Out(len); {segname} for i := 1 to len do Out(ord(name^[i])); end; {Header} procedure OpenSeg; { create a new segment and mark its beginning } begin {OpenSeg} segDisp := 0; segStart := objPtr; end; {OpenSeg} procedure OpenObj {var name: gsosOutString}; { open a new obj file with the indicated file name } { } { parameters: } { name - object file name } var dsDCBGS: destroyOSDCB; {dcb for Destroy call} giDCBGS: getFileInfoOSDCB; {dcb for Get_File_Info call} begin {OpenObj} {the file is not spooled (yet)} spoolRefnum := 0; {if there is an existing file, delete it} if memoryCompile then begin giDCBGS.pCount := 12; giDCBGS.pathName := @name.theString; GetFileInfoGS(giDCBGS); if ToolError = 0 then if giDCBGS.fileType = OBJ then begin dsDCBGS.pCount := 1; dsDCBGS.pathName := @name.theString; DestroyGS(dsDCBGS); end; {if} end; {if} {allocate memory for an initial buffer} objHandle := pointer(NewHandle(buffSize, userID, $8000, nil)); {set up the buffer variables} if ToolError = 0 then begin objLen := 0; objPtr := objHandle^; end {if} else TermError(5); {save the object file name} objFile := name; end; {OpenObj} procedure Purge; { write any constant bytes to the output buffer } var i: integer; {loop variable} begin {Purge} if cBuffLen <> 0 then begin Out(cBuffLen); for i := 0 to cBuffLen-1 do COut(cBuff[i]); cBuffLen := 0; end; {if} end; {Purge} end. {$append 'objout2.asm'} \ No newline at end of file diff --git a/Parser.pas b/Parser.pas new file mode 100755 index 0000000..3272ed2 --- /dev/null +++ b/Parser.pas @@ -0,0 +1 @@ +{$optimize 1} {---------------------------------------------------------------} { } { Parser } { } { External Subroutines: } { } { DoDeclaration - process a variable or function declaration } { DoStatement - process a statement from a function } { InitParser - initialize the parser } { Match - insure that the next token is of the specified type } { TermParser - shut down the parser } { TypeSpecifier - handle a type specifier } { } {---------------------------------------------------------------} unit Parser; {$LibPrefix '0/obj/'} interface uses CCommon, Table, MM, CGI, Scanner, Header, Symbol, Expression, Asm; {$segment 'parser'} {---------------------------------------------------------------} procedure DoDeclaration (doingPrototypes: boolean); { process a variable or function declaration } { } { parameters: } { doingPrototypes - are we processing a parameter list? } procedure DoStatement; { process a statement from a function } procedure InitParser; { Initialize the parser } procedure Match (kind: tokenEnum; err: integer); { insure that the next token is of the specified type } { } { parameters: } { kind - expected token kind } { err - error number if the expected token is not found } procedure TermParser; { shut down the parser } procedure TypeSpecifier (doingFieldList,isConstant: boolean); { handle a type specifier } { } { parameters: } { doingFieldList - are we processing a field list? } { isConstant - did we already find a constsy? } {---------------------------------------------------------------} implementation const maxBitField = 32; {max # of bits in a bit field} type identList = ^identNode; {list of ids; used for initializers} identNode = record next: identList; id: identPtr; end; { The switch record is used to record the values for the } { switch jump table. The linked list of entries is in order } { of increasing switch value (val). } switchPtr = ^switchRecord; {switch label table entry} switchRecord = record next,last: switchPtr; {doubly linked list (for inserts)} lab: integer; {label to branch to} val: longint; {switch value} end; {token stack} {-----------} tokenStackPtr = ^tokenStackRecord; tokenStackRecord = record next: tokenStackPtr; token: tokenType; end; {statement stack} {---------------} statementPtr = ^statementRecord; {kinds of nestable statements} statementKind = (compoundSt,ifSt,elseSt,doSt,whileSt,forSt,switchSt); statementRecord = record {element of the statement stack} next: statementPtr; {next element on the stack} breakLab, continueLab: integer; {branch points for break, continue} case kind: statementKind of compoundSt: ( doingDeclaration: boolean; {doing declarations? (or statements)} ); ifSt: ( ifLab: integer; {branch point} ); elseSt: ( elseLab: integer; {branch point} ); doSt: ( doLab: integer; {branch point} ); whileSt: ( whileTop: integer; {label at top of while loop} whileEnd: integer; {label at bottom of while loop} ); forSt: ( forLoop: integer; {branch here to loop} e3List: tokenStackPtr; {tokens for last expression} ); switchSt: ( maxVal: longint; {max switch value} isLong: boolean; {do long switch?} ln: integer; {temp var number} size: integer; {temp var size} labelCount: integer; {# of switch labels} switchExit: integer; {branch point} switchLab: integer; {branch point} switchList: switchPtr; {list of labels and values} switchDefault: integer; {default branch point} ); end; var doingMain: boolean; {are we processing the main function?} firstCompoundStatement: boolean; {are we doing a function level compound statement?} fType: typePtr; {return type of the current function} initializerList: identList; {list of initialized identifiers} isForwardDeclared: boolean; {is the field list component } { referenceing a forward struct/union? } isFunction: boolean; {is the declaration a function?} isPascal: boolean; {has the pascal modifier been used?} { (set by DoDeclaration)} returnLabel: integer; {label for exit point} skipDeclarator: boolean; {for enum,struct,union with no declarator} statementList: statementPtr; {list of open statements} {parameter processing variables} {------------------------------} lastParameter: identPtr; {next parameter to process} numberOfParameters: integer; {number of indeclared parameters} pfunc: identPtr; {func. for which parms are being defined} protoType: typePtr; {type from a parameter list} protoVariable: identPtr; {variable from a parameter list} {type info for the current declaration} {-------------------------------------} storageClass: tokenEnum; {storage class of the declaration} { typeSpec: typePtr; (in CCommon) {type specifier} {-- Parser Utility Procedures ----------------------------------} procedure Match {kind: tokenEnum; err: integer}; { insure that the next token is of the specified type } { } { parameters: } { kind - expected token kind } { err - error number if the expected token is not found } begin {Match} if token.kind = kind then NextToken else Error(err); end; {Match} procedure SkipStatement; { Skip the remainder of the current statement } var bracketCount: integer; {for error skip} begin {SkipStatement} bracketCount := 0; while (token.kind <> eofsy) and ((token.kind <> semicolonch) or (bracketCount <> 0)) do begin if token.kind = lbrackch then bracketCount := bracketCount+1; if token.kind = rbrackch then if bracketCount <> 0 then bracketCount := bracketCount-1; NextToken; end; {while} if token.kind = semicolonch then NextToken; end; {SkipStatement} procedure GotoLabel (op: pcodes); { Find a label in the goto label list, creating one if one } { does not already exist. Generate the label or a jump to it } { based on op. } { } { paremeters: } { op - operation code to create } label 1; var gt: gotoPtr; {work pointer} begin {GotoLabel} gt := gotoList; {try to find an existing label} while gt <> nil do begin if gt^.name^ = token.name^ then goto 1; gt := gt^.next; end; {while} gt := pointer(Malloc(sizeof(gotoRecord))); {no label record exists: create one} gt^.next := gotoList; gotoList := gt; gt^.name := token.name; gt^.lab := GenLabel; gt^.defined := false; 1: if op = dc_lab then begin if gt^.defined then Error(77) else begin gt^.defined := true; Gen1(dc_lab, gt^.lab); end; {else} end {if} else Gen1(pc_ujp, gt^.lab); end; {GotoLabel} {-- Statements -------------------------------------------------} procedure CompoundStatement (makeSymbols: boolean); { handle a compound statement } { } { Parameters: } { makeSymbols - create a symbol table? (False for a } { function's outer wrapper, true for imbeded statements) } var stPtr: statementPtr; {for creating a compound statement record} begin {CompoundStatement} Match(lbracech,27); {make sure there is an opening '{'} new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := compoundSt; if makeSymbols then {create a symbol table} PushTable; stPtr^.doingDeclaration := true; {allow declarations} initializerList := nil; {no initializers, yet} end; {CompoundStatement} procedure EndCompoundStatement; { finish off a compound statement } var dumpLocal: boolean; {dump the local memory pool?} tl: tempPtr; {work pointer} stPtr: statementPtr; {work pointer} begin {EndCompoundStatement} dumpLocal := false; stPtr := statementList; {pop the statement record} statementList := stPtr^.next; doingFunction := statementList <> nil; {see if we're done with the function} if not doingFunction then begin {if so, finish it off} Gen1(dc_lab, returnLabel); with fType^ do {generate the pc_ret instruction} case kind of scalarType : Gen0t(pc_ret, baseType); arrayType : ; structType , unionType , pointerType : Gen0t(pc_ret, cgULong); functionType: ; enumConst : ; enumType : Gen0t(pc_ret, cgWord); definedType : ; otherwise: Error(57); end; {case} Gen0 (dc_enp); {finish the segment} CheckGotoList; {make sure all labels are declared} while tempList <> nil do begin {dump the local labels} tl := tempList; tempList := tl^.next; dispose(tl); end; {while} dumpLocal := true; {dump the local pool} nameFound := false; {no pc_nam for the next function (yet)} end; {if} PopTable; {remove this symbol table} dispose(stPtr); {dump the record} if dumpLocal then begin useGlobalPool := true; {start using the global memory pool} LInit; {dispose of the local memory pool} end; {if} NextToken; {remove the rbracech token} end; {EndCompoundStatement} procedure Statement; { handle a statement } label 1; var lToken,tToken: tokenType; {for look-ahead} lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} function GetSwitchRecord: statementPtr; { Find the enclosing switch statement } { } { Returns a pointer to the closest switch statement record, } { or nil if there are none. } label 1; var stPtr: statementPtr; {work pointer} begin {GetSwitchRecord} stPtr := statementList; while stPtr <> nil do begin if stPtr^.kind = switchSt then goto 1; stPtr := stPtr^.next; end; {while} 1: GetSwitchRecord := stPtr; end; {GetSwitchRecord} procedure AssignmentStatement; { handle an asignment statement } begin {AssignmentStatement} if token.kind in startExpression then begin Expression(normalExpression, [semicolonch]); if expressionType^.baseType <> cgVoid then Gen0t(pc_pop, UsualUnaryConversions); if token.kind = semicolonch then NextToken else begin Error(22); SkipStatement; end; {else} end {if} else begin NextToken; Error(92); end; {else} end; {AssignmentStatement} procedure BreakStatement; { handle a break statement } label 1,2; var stPtr: statementPtr; {work pointer} begin {BreakStatement} stPtr := statementList; {find the proper statement} while stPtr <> nil do begin if stPtr^.kind in [whileSt,doSt,forSt,switchSt] then goto 1; stPtr := stPtr^.next; end; {while} Error(76); goto 2; 1: if stPtr^.breakLab = 0 then {if there is no break label, create one} stPtr^.breakLab := GenLabel; Gen1(pc_ujp, stPtr^.breakLab); {branch to the break label} 2: NextToken; {skip the 'break' token} Match(semicolonch,22); {insist on a closing ';'} end; {BreakStatement} procedure CaseStatement; { handle a case statement } var stPtr: statementPtr; {switch record for this case label} swPtr,swPtr2: switchPtr; {work pointers for inserting new entry} val: integer; {case label value} begin {CaseStatement} while token.kind = casesy do begin NextToken; {skip the 'case' token} stPtr := GetSwitchRecord; {get the proper switch record} Expression(arrayExpression, [colonch]); {evaluate the branch condition} val := long(expressionValue).lsw; if val <> expressionValue then if not stPtr^.isLong then Error(71); if stPtr = nil then Error(72) else begin new(swPtr2); {create the new label table entry} swPtr2^.lab := GenLabel; Gen1(dc_lab, swPtr2^.lab); swPtr2^.val := expressionValue; swPtr := stPtr^.switchList; if swPtr = nil then begin {enter it in the table} swPtr2^.last := nil; swPtr2^.next := nil; stPtr^.switchList := swPtr2; stPtr^.maxVal := expressionValue; stPtr^.labelCount := 1; end {if} else begin while (swPtr^.next <> nil) and (swPtr^.val < expressionValue) do swPtr := swPtr^.next; if swPtr^.val = expressionValue then Error(73) else if swPtr^.val > expressionValue then begin swPtr2^.next := swPtr; if swPtr^.last = nil then stPtr^.switchList := swPtr2 else swPtr^.last^.next := swPtr2; swPtr2^.last := swPtr^.last; swPtr^.last := swPtr2; end {else if} else begin {at end of list} swPtr2^.next := nil; swPtr2^.last := swPtr; swPtr^.next := swPtr2; stPtr^.maxVal := expressionValue; end; {else} stPtr^.labelCount := stPtr^.labelCount + 1; end; {else} end; {else} Match(colonch,29); {get the colon} end; {while} Statement; {process the labeled statement} end; {CaseStatement} procedure ContinueStatement; { handle a continue statement } label 1,2; var stPtr: statementPtr; {work pointer} begin {ContinueStatement} stPtr := statementList; {find the proper statement} while stPtr <> nil do begin if stPtr^.kind in [whileSt,doSt,forSt] then goto 1; stPtr := stPtr^.next; end; {while} Error(75); goto 2; 1: if stPtr^.continueLab = 0 then {if there is no continue label, create one} stPtr^.continueLab := GenLabel; Gen1(pc_ujp, stPtr^.continueLab); {branch to the continue label} 2: NextToken; {skip the 'continue' token} Match(semicolonch,22); {insist on a closing ';'} end; {ContinueStatement} procedure DefaultStatement; { handle a default statement } var stPtr: statementPtr; {work pointer} begin {DefaultStatement} NextToken; {skip the 'default' token} Match(colonch,29); {get the colon} stPtr := GetSwitchRecord; {record the presense of a default label} if stPtr = nil then Error(72) else if stPtr^.switchDefault <> 0 then Error(74) else begin stPtr^.switchDefault := GenLabel; Gen1(dc_lab, stPtr^.switchDefault); end; {else} Statement; {process the labeled statement} end; {DefaultStatement} procedure DoStatement; { handle a do statement } var lab: integer; {branch label} stPtr: statementPtr; {work pointer} begin {DoStatement} NextToken; {skip the 'do' token} new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := doSt; lab := GenLabel; {create the branch label} Gen1(dc_lab, lab); stPtr^.doLab := lab; stPtr^.breakLab := 0; stPtr^.continueLab := 0; Statement; {process the first loop body statement} end; {DoStatement} procedure ForStatement; { handle a for statement } var errorFound: boolean; {did we find an error?} forLoop, continueLab, breakLab: integer; {branch points} lType: typePtr; {type of "left" expression} parencount: integer; {number of unmatched '(' chars} stPtr: statementPtr; {work pointer} tl,tk: tokenStackPtr; {for forming expression list} begin {ForStatement} NextToken; {skip the 'for' token} new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := forSt; forLoop := GenLabel; {create the branch labels} continueLab := GenLabel; breakLab := GenLabel; stPtr^.forLoop := forLoop; stPtr^.continueLab := continueLab; stPtr^.breakLab := breakLab; Match(lparench,13); {evaluate the start condition} if token.kind <> semicolonch then begin Expression(normalExpression, [semicolonch]); Gen0t(pc_pop, UsualUnaryConversions); end; {if} Match(semicolonch,22); Gen1(dc_lab, forLoop); {this label points to the condition} if token.kind <> semicolonch then {handle the loop test} begin {evaluate the expression} Expression(normalExpression, [semicolonch]); CompareToZero(pc_neq); {Evaluate the condition} Gen1(pc_fjp, breakLab); end; {if} Match(semicolonch,22); tl := nil; {collect the tokens for the last expression} parencount := 0; errorFound := false; while (token.kind <> eofsy) and ((token.kind <> rparench) or (parencount <> 0)) and (token.kind <> semicolonch) do begin new(tk); {place the token in the list} tk^.next := tl; tl := tk; tk^.token := token; if token.kind = lparench then {allow parens in the expression} parencount := parencount+1 else if token.kind = rparench then parencount := parencount-1; NextToken; {next token} end; {while} if errorFound then {if an error was found, dump the list} while tl <> nil do begin tk := tl; tl := tl^.next; dispose(tk); end; {while} stPtr^.e3List := tl; {save the list} Match(rparench,12); {get the closing for loop paren} Statement; {process the first loop body statement} end; {ForStatement} procedure IfStatement; { handle an if statement } var lab: integer; {branch label} lType: typePtr; {type of "left" expression} stPtr: statementPtr; {work pointer} begin {IfStatement} NextToken; {skip the 'if' token} Match(lparench, 13); {evaluate the condition} Expression(normalExpression, [rparench]); Match(rparench, 12); lab := GenLabel; {create the branch label} CompareToZero(pc_neq); {evaluate the condition} Gen1(pc_fjp, lab); new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := ifSt; stPtr^.ifLab := lab; Statement; {process the 'true' statement} end; {IfStatement} procedure GotoStatement; { handle a goto statement } begin {GotoStatement} NextToken; {skip the 'goto' token} if token.kind in [ident,typedef] then begin GotoLabel(pc_ujp); {jump to the label} NextToken; {skip the token} end {if} else Error(9); {flag the error} Match(semicolonch, 22); {insist on a closing ';'} end; {GotoStatement} procedure LabelStatement; { handle a labeled statement } begin {LabelStatement} GotoLabel(dc_lab); {define the label} NextToken; {skip the label} if token.kind = colonch then {if present, skip the colon} NextToken else begin {bad statement - flag error and skip it} Error(31); SkipStatement; end; {else} end; {LabelStatement} procedure ReturnStatement; { handle a return statement } var id: identPtr; {structure id} size: longint; {size of the struct/union} tk: tokenType; {structure name token} begin {ReturnStatement} NextToken; {skip the 'return' token} if token.kind <> semicolonch then {if present, evaluate the return value} begin if fType^.kind in [structType,unionType] then begin tk.kind := ident; tk.class := identifier; tk.name := @'@struct'; tk.symbolPtr := nil; id := FindSymbol(tk, variableSpace, false, true); Gen1Name(pc_lao, 0, id^.name); size := fType^.size; end; {if} Expression(normalExpression, [semicolonch]); AssignmentConversion(fType, expressionType, lastWasConst, lastConst, true, true); case fType^.kind of scalarType: Gen2t(pc_str, 0, 0, fType^.baseType); enumType: Gen2t(pc_str, 0, 0, cgWord); pointerType: Gen2t(pc_str, 0, 0, cgULong); structType, unionType: begin Gen2(pc_mov, long(size).msw, long(size).lsw); Gen0t(pc_pop, cgULong); end; otherwise: ; end; {case} end; {if} Gen1(pc_ujp, returnLabel); {branch to the exit point} Match(semicolonch, 22); {insist on a closing ';'} end; {ReturnStatement} procedure SwitchStatement; { handle a switch statement } var stPtr: statementPtr; {work pointer} tp: typePtr; {for checking type} begin {SwitchStatement} NextToken; {skip the 'switch' token} new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := switchSt; stPtr^.maxVal := -maxint4; stPtr^.isLong := false; stPtr^.labelCount := 0; stPtr^.switchLab := GenLabel; stPtr^.switchExit := GenLabel; stPtr^.breakLab := stPtr^.switchExit; stPtr^.switchList := nil; stPtr^.switchDefault := 0; Match(lparench, 13); {evaluate the condition} Expression(normalExpression,[rparench]); Match(rparench, 12); tp := expressionType; {make sure the expression is integral} while tp^.kind = definedType do tp := tp^.dType; case tp^.kind of scalarType: if tp^.baseType in [cgLong,cgULong] then begin stPtr^.isLong := true; stPtr^.size := cgLongSize; stPtr^.ln := GetTemp(cgLongSize); Gen2t(pc_str, stPtr^.ln, 0, cgLong); end {if} else if tp^.baseType in [cgByte,cgUByte,cgWord,cgUWord] then begin stPtr^.isLong := false; stPtr^.size := cgWordSize; stPtr^.ln := GetTemp(cgWordSize); Gen2t(pc_str, stPtr^.ln, 0, cgWord); end {else if} else Error(71); enumType: begin stPtr^.isLong := false; stPtr^.size := cgWordSize; stPtr^.ln := GetTemp(cgWordSize); Gen2t(pc_str, stPtr^.ln, 0, cgWord); end; otherwise: Error(71); end; {case} Gen1(pc_ujp, stPtr^.switchLab); {branch to the xjp instruction} Statement; {process the loop body statement} end; {SwitchStatement} procedure WhileStatement; { handle a while statement } var lType: typePtr; {type of "left" expression} stPtr: statementPtr; {work pointer} top, endl: integer; {branch points} begin {WhileStatement} NextToken; {skip the 'while' token} new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := whileSt; top := GenLabel; {create the branch labels} endl := GenLabel; stPtr^.whileTop := top; stPtr^.whileEnd := endl; stPtr^.breakLab := endl; stPtr^.continueLab := top; Gen1(dc_lab, top); {define the top label} Match(lparench, 13); {evaluate the condition} Expression(normalExpression, [rparench]); Match(rparench, 12); CompareToZero(pc_neq); {evaluate the condition} Gen1(pc_fjp, endl); Statement; {process the first loop body statement} end; {WhileStatement} begin {Statement} 1: {if trace names are enabled and a line # is due, generate it} if traceBack or debugFlag then if nameFound or debugFlag then if lastLine <> lineNumber then begin lastLine := lineNumber; Gen2(pc_lnm, lineNumber, ord(debugType)); end; {if} {handle the statement} case token.kind of asmsy: begin NextToken; AsmStatement; end; breaksy: BreakStatement; casesy: CaseStatement; continuesy: ContinueStatement; defaultsy: DefaultStatement; dosy: DoStatement; elsesy: begin Error(25); SkipStatement; end; forsy: ForStatement; gotosy: GotoStatement; typedef, ident: begin lPrintMacroExpansions := printMacroExpansions; printMacroExpansions := false; lToken := token; NextToken; tToken := token; PutBackToken(token, true); token := lToken; printMacroExpansions := lPrintMacroExpansions; if tToken.kind = colonch then begin LabelStatement; goto 1; end {if} else AssignmentStatement; end; ifsy: IfStatement; lbracech: CompoundStatement(true); returnsy: ReturnStatement; semicolonch: NextToken; switchsy: SwitchStatement; whilesy: WhileStatement; otherwise: AssignmentStatement; end; {case} end; {Statement} procedure EndDoStatement; { finish off a do statement } var lType: typePtr; {type of "left" expression} stPtr: statementPtr; {work pointer} begin {EndDoStatement} stPtr := statementList; {get the statement record} if token.kind = whilesy then begin {if a while clause exists, process it} NextToken; {skip the 'while' token} if stPtr^.continueLab <> 0 then {create the continue label} Gen1(dc_lab, stPtr^.continueLab); Match(lparench, 13); {evaluate the condition} Expression(normalExpression, [rparench]); Match(rparench, 12); CompareToZero(pc_equ); {evaluate the condition} Gen1(pc_fjp, stPtr^.doLab); Match(semicolonch, 22); {process the closing ';'} end {if} else Error(30); {'while' expected} if stPtr^.breakLab <> 0 then {create the break label} Gen1(dc_lab, stPtr^.breakLab); statementList := stPtr^.next; {pop the statement record} dispose(stPtr); end; {EndDoStatement} procedure EndIfStatement; { finish off an if statement } var lab1,lab2: integer; {branch labels} stPtr: statementPtr; {work pointer} begin {EndIfStatement} stPtr := statementList; {get the label to branch to} lab1 := stPtr^.ifLab; statementList := stPtr^.next; {pop the statement record} dispose(stPtr); if token.kind = elsesy then begin {if an else clause exists, process it} NextToken; {skip 'else'} lab2 := GenLabel; {create the branch label} Gen1(pc_ujp, lab2); {branch past the else clause} Gen1(dc_lab, lab1); {create label for if to branch to} new(stPtr); {create a statement record} stPtr^.next := statementList; statementList := stPtr; stPtr^.kind := elseSt; stPtr^.elseLab := lab2; Statement; {evaluate the else clause} end {if} else Gen1(dc_lab, lab1); {create label for if to branch to} end; {EndIfStatement} procedure EndElseStatement; { finish off an else clause } var stPtr: statementPtr; {work pointer} begin {EndElseStatement} stPtr := statementList; {create the label to branch to} Gen1(dc_lab, stPtr^.elseLab); statementList := stPtr^.next; {pop the statement record} dispose(stPtr); end; {EndElseStatement} procedure EndForStatement; { finish off a for statement } var ltoken: tokenType; {for putting ; on stack} stPtr: statementPtr; {work pointer} tl,tk: tokenStackPtr; {for forming expression list} lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} begin {EndForStatement} stPtr := statementList; Gen1(dc_lab, stPtr^.continueLab); {define the continue label} tl := stPtr^.e3List; {place the expression back in the list} if tl <> nil then begin PutBackToken(token, false); ltoken.kind := semicolonch; ltoken.class := reservedSymbol; PutBackToken(ltoken, false); while tl <> nil do begin PutBackToken(tl^.token, false); tk := tl; tl := tl^.next; dispose(tk); end; {while} lPrintMacroExpansions := printMacroExpansions; {inhibit token echo} printMacroExpansions := false; NextToken; {evaluate the expression} Expression(normalExpression, [semicolonch]); Gen0t(pc_pop, UsualUnaryConversions); NextToken; {skip the seminolon} printMacroExpansions := lPrintMacroExpansions; end; {if} Gen1(pc_ujp, stPtr^.forLoop); {loop to the test} Gen1(dc_lab, stPtr^.breakLab); {create the exit label} statementList := stPtr^.next; {pop the statement record} dispose(stPtr); end; {EndForStatement} procedure EndSwitchStatement; { finish off a switch statement } const sparse = 5; {label to tableSize ratio for sparse table} var default: integer; {default label} ltp: baseTypeEnum; {base type} minVal: integer; {min switch value} stPtr: statementPtr; {work pointer} {copies of vars (for efficiency)} {-------------------------------} exitLab: integer; {label at the end of the jump table} isLong: boolean; {is the case expression long?} swPtr,swPtr2: switchPtr; {switch label table list} begin {EndSwitchStatement} stPtr := statementList; {get the statement record} exitLab := stPtr^.switchExit; {get the exit label} isLong := stPtr^.isLong; {get the long flag} swPtr := stPtr^.switchList; {Skip further generation if there were} if swPtr <> nil then begin { no labels. } default := stPtr^.switchDefault; {get a default label} if default = 0 then default := exitLab; Gen1(pc_ujp, exitLab); {branch past the indexed jump} Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table} if isLong then {decide on a base type} ltp := cgLong else ltp := cgWord; if stPtr^.isLong or (((stPtr^.maxVal-swPtr^.val) div stPtr^.labelCount) > sparse) then begin {Long expressions and sparse switch statements are handled as a } {series of if-goto tests. } while swPtr <> nil do begin {generate the compares} if isLong then GenLdcLong(swPtr^.val) else Gen1t(pc_ldc, long(swPtr^.val).lsw, cgWord); Gen2t(pc_lod, stPtr^.ln, 0, ltp); Gen0t(pc_equ, ltp); Gen1(pc_tjp, swPtr^.lab); swPtr2 := swPtr; swPtr := swPtr^.next; dispose(swPtr2); end; {while} Gen1(pc_ujp, default); {anything else goes to default} end {if} else begin {compact word switch statements are handled with xjp} minVal := long(swPtr^.val).lsw; {record the min label value} Gen2t(pc_lod, stPtr^.ln, 0, ltp); {get the value} Gen1t(pc_dec, minVal, cgWord); {adjust the range} Gen1(pc_xjp, ord(stPtr^.maxVal-minVal+1)); {do the indexed jump} while swPtr <> nil do begin {generate the jump table} while minVal < swPtr^.val do begin Gen1(pc_add, default); minVal := minVal+1; end; {while} minVal := minVal+1; Gen1(pc_add, swPtr^.lab); swPtr2 := swPtr; swPtr := swPtr^.next; dispose(swPtr2); end; {while} Gen1(pc_add, default); end; {if} Gen1(dc_lab, exitLab); {generate the default label} end {if} else begin Gen1(pc_ujp, exitLab); {branch past the indexed jump} Gen1(dc_lab, stPtr^.switchLab); {create the label for the xjp table} default := stPtr^.switchDefault; {if there is one, jump to the default label} if default <> 0 then Gen1(pc_ujp, default); Gen1(dc_lab, exitLab); {generate the default label} end; {else} FreeTemp(stPtr^.ln, stPtr^.size); {release temp variable} statementList := stPtr^.next; {pop the statement record} dispose(stPtr); end; {EndSwitchStatement} procedure EndWhileStatement; { finish off a while statement } var stPtr: statementPtr; {work pointer} begin {EndWhileStatement} stPtr := statementList; {loop to the test} Gen1(pc_ujp, stPtr^.whileTop); Gen1(dc_lab, stPtr^.whileEnd); {create the exit label} statementList := stPtr^.next; {pop the statement record} dispose(stPtr); end; {EndWhileStatement} {-- Type declarations ------------------------------------------} procedure Declarator(tPtr: typePtr; var variable: identPtr; space: spaceType; doingPrototypes: boolean); { handle a declarator } { } { parameters: } { tPtr - pointer to the type to use } { variable - pointer to variable being defined } { space - variable space to use } { doingPrototypes - are we compiling prototype parameter } { declarations? } label 1; type typeDefPtr = ^typeDefRecord; {for stacking type records} typeDefRecord = record next: typeDefPtr; typeDef: typePtr; end; pointerListPtr = ^pointerList; {for stacking pointer types} pointerList = record next: pointerListPtr; isConstant: boolean; end; var i: integer; {loop variable} lastWasIdentifier: boolean; {for deciding if the declarator is a fuction} lastWasPointer: boolean; {was the last type a pointer?} newName: stringPtr; {new symbol name} parameterStorage: boolean; {is the new symbol in a parm list?} state: stateKind; {declaration state of the variable} tPtr2: typePtr; {work pointer} tsPtr: typeDefPtr; {work pointer} typeStack: typeDefPtr; {stack of type definitions} varParmList: boolean; {did we prototype a variable?} {for checking function compatibility} {-----------------------------------} checkParms: boolean; {do we need to do type checking on the parm?} compatible: boolean; {are the parameters compatible?} ftoken: tokenType; {for checking extern functions} p1,p2,p3: parameterPtr; {used to trace parameter lists} pt1,pt2: typePtr; {parameter types} t1: typePtr; {function type} tk1,tk2: typeKind; {parameter type kinds} unnamedParm: boolean; {is this an unnamed prototype?} procedure StackDeclarations (var varParmList: boolean); { stack the declaration operators } { } { Parameters: } { varParmList - did we create one? } var cp,cpList: pointerListPtr; {pointer list} done,done2: boolean; {for loop termination} isPtr: boolean; {is the parenthesized expr a ptr?} wp: parameterPtr; {used to build prototype var list} pvar: identPtr; {work pointer} tPtr2: typePtr; {work pointer} ttPtr: typeDefPtr; {work pointer} parencount: integer; {for skipping in parm list} lvarParmList: boolean; {did we prototype a variable?} {variables used to preserve states} { across recursive calls } {---------------------------------} lisFunction: boolean; {local copy of isFunction} lisPascal: boolean; {local copy of isPascal} lLastParameter: identPtr; {next parameter to process} lstorageClass: tokenEnum; {storage class of the declaration} ltypeSpec: typePtr; {type specifier} luseGlobalPool: boolean; {local copy of useGlobalPool} lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} begin {StackDeclarations} varParmList := false; {no var parm list, yet} lastWasIdentifier := false; {used to see if the declaration is a fn} cpList := nil; if token.kind = typedef then token.kind := ident; case token.kind of ident: begin {handle 'ident'} if space = fieldListSpace then variable := nil else variable := FindSymbol(token, space, true, true); newName := token.name; if variable = nil then begin if storageClass = typedefsy then begin tPtr2 := pointer(Calloc(sizeof(typeRecord))); {tPtr2^.size := 0;} {tPtr2^.saveDisp := 0;} tPtr2^.kind := definedType; {tPtr^.isConstant := false;} tPtr2^.dType := tPtr; end {if} else tPtr2 := tPtr; if doingParameters then begin if not doingPrototypes then if not (tPtr2^.kind in [enumConst,structType,unionType,definedType,pointerType]) then Error(50); parameterStorage := true; end; {if} end {if} else checkParms := true; NextToken; if token.kind = eqch then state := initialized; lastWasIdentifier := true; end; asteriskch: begin {handle '*' 'declarator'} while token.kind = asteriskch do begin NextToken; new(cp); cp^.next := cpList; cpList := cp; cp^.isConstant := false; while token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy, doublesy,compsy,extendedsy,voidsy,enumsy,structsy,unionsy, volatilesy,constsy] do begin if token.kind = constsy then cpList^.isConstant := true else if token.kind = volatilesy then volatile := true else Error(9); NextToken; end; {while} end; {while} StackDeclarations(lvarParmList); end; lparench: begin {handle '(' 'declarator' ')'} NextToken; isPtr := token.kind = asteriskch; StackDeclarations(lvarParmList); Match(rparench,12); if isPtr then lastWasIdentifier := false; end; otherwise: if doingPrototypes then begin {allow for unnamed parameters} pvar := pointer(Calloc(sizeof(identRecord))); {pvar^.next := nil;} {pvar^.saved := 0;} pvar^.name := @'?'; pvar^.itype := tPtr; {pvar^.disp := 0;} {pvar^.bitDisp := 0;} {pvar^.bitsize := 0;} {pvar^.initialized := false;} {pvar^.iPtr := nil;} {pvar^.isForwardDeclared := false;} pvar^.class := autosy; pvar^.storage := parameter; variable := pvar; lastWasIdentifier := true; newName := nil; unnamedParm := true; end; {if} end; {case} while token.kind in [lparench,lbrackch] do begin {handle function declarations} if token.kind = lparench then begin lisPascal := isPascal; {preserve this flag} PushTable; {create a symbol table} {determine if it's a function} isFunction := lastWasIdentifier or isFunction; varParmList := not isFunction; tPtr2 := pointer(GCalloc(sizeof(typeRecord))); {create the function type} {tPtr2^.size := 0;} {tPtr2^.saveDisp := 0;} tPtr2^.kind := functionType; {tPtr2^.isConstant := false;} {tPtr2^.varargs := false;} {tPtr2^.prototyped := false;} {tPtr2^.overrideKR := false;} {tPtr2^.parameterList := nil;} {tPtr2^.isPascal := false;} {tPtr2^.toolNum := 0;} {tPtr2^.dispatcher := 0;} new(ttPtr); ttPtr^.next := typeStack; typeStack := ttPtr; ttPtr^.typeDef := tPtr2; NextToken; {skip the '(' token} if token.kind = voidsy then begin {check for a void prototype} lPrintMacroExpansions := printMacroExpansions; printMacroExpansions := false; NextToken; printMacroExpansions := lPrintMacroExpansions; if token.kind = rparench then begin PutBackToken(token, false); NextToken; tPtr2^.prototyped := true; end else begin PutBackToken(token, false); token.kind := voidsy; token.class := reservedSymbol; end; {else} end; {if} if token.kind in {see if we are doing a prototyped list} [autosy,externsy,registersy,staticsy,typedefsy,unsignedsy,intsy, longsy,charsy,shortsy,floatsy,doublesy,compsy,extendedsy,voidsy, enumsy,structsy,unionsy,typedef,signedsy,constsy] then begin {handle a prototype variable list} numberOfParameters := 0; {don't allow K&R parm declarations} luseGlobalPool := useGlobalPool; {use global memory} useGlobalPool := true; done2 := false; lisFunction := isFunction; {preserve global variables} ltypeSpec := typeSpec; lstorageClass := storageClass; with tPtr2^ do begin prototyped := true; {it is prototyped} repeat {collect the declarations} if (token.kind in [autosy,externsy,registersy,staticsy, typedefsy,unsignedsy,signedsy,intsy,longsy, charsy,shortsy,floatsy,doublesy,compsy, extendedsy,enumsy,structsy,unionsy, typedef,voidsy,volatilesy,constsy]) then begin lLastParameter := lastParameter; DoDeclaration(true); lastParameter := lLastParameter; if protoType <> nil then begin wp := pointer(Malloc(sizeof(parameterRecord))); wp^.next := parameterList; parameterList := wp; wp^.parameter := protoVariable; wp^.parameterType := protoType; if protoVariable <> nil then begin protoVariable^.pnext := lastParameter; lastParameter := protoVariable; end; {if} end; {if} if token.kind = commach then begin NextToken; if token.kind = dotch then begin NextToken; Match(dotch,89); Match(dotch,89); varargs := true; done2 := true; end; {if} end {if} else done2 := true; end {if} else begin Error(26); parencount := 0; while (token.kind <> eofsy) and ((parencount > 0) or (token.kind <> rparench)) do begin if token.kind = rparench then parencount := parencount-1 else if token.kind = lparench then parencount := parencount+1; NextToken; end; {while} done2 := true; end; {else} until done2; end; {with} isFunction := lisFunction; {restore global variables} storageClass := lstorageClass; typeSpec := ltypeSpec; useGlobalPool := luseGlobalPool; end {if prototype} else if token.kind = ident then begin {handle a K&R variable list} if (lint & lintNotPrototyped) <> 0 then Error(105); if doingFunction or doingPrototypes then Error(12) else begin numberOfParameters := 0; {no function parms yet} end; {else} repeat {make a list of parameters} if not doingFunction then begin if token.kind <> ident then begin Error(9); while not (token.kind in [rparench,commach,ident]) do NextToken; end; {if} if token.kind = ident then begin pvar := NewSymbol(token.name, nil, ident, variableSpace, declared); pvar^.storage := parameter; pvar^.pnext := lastParameter; lastParameter := pvar; numberOfParameters := numberOfParameters+1; pvar^.bitdisp := numberOfParameters; NextToken; end; {if} end; {if} if token.kind = commach then begin NextToken; done := false; end {if} else done := true; until done or (token.kind = eofsy); end {else if} else if (lint & lintNotPrototyped) <> 0 then if not tPtr2^.prototyped then Error(105); Match(rparench,12); {insist on a closing ')' token} isPascal := lisPascal; {restore this flag} end {if} {handle array declarations} else {if token.kind = lbrackch then} begin lastWasIdentifier := false; tPtr2 := pointer(Calloc(sizeof(typeRecord))); {tPtr2^.size := 0;} {tPtr2^.saveDisp := 0;} {tPtr2^.isConstant := false;} tPtr2^.kind := arrayType; {tPtr2^.elements := 0;} new(ttPtr); ttPtr^.next := typeStack; typeStack := ttPtr; ttPtr^.typeDef := tPtr2; NextToken; if token.kind <> rbrackch then begin Expression(arrayExpression, [rbrackch,semicolonch]); if expressionValue <= 0 then begin Error(45); expressionValue := 1; end; {if} tPtr2^.elements := expressionValue; end; {if} Match(rbrackch,24); end; {else if} end; {while} {stack pointer type records} while cpList <> nil do begin tPtr2 := pointer(Malloc(sizeof(typeRecord))); tPtr2^.size := cgPointerSize; tPtr2^.saveDisp := 0; tPtr2^.isConstant := cpList^.isConstant; tPtr2^.kind := pointerType; new(ttPtr); ttPtr^.next := typeStack; typeStack := ttPtr; ttPtr^.typeDef := tPtr2; cp := cpList; cpList := cp^.next; dispose(cp); end; {for} end; {StackDeclarations} begin {Declarator} newName := nil; {no identifier, yet} unnamedParm := false; {not an unnamed parameter} if storageClass = externsy then {decide on a storage state} state := declared else state := defined; typeStack := nil; {no types so far} parameterStorage := false; {symbol is not in a parameter list} checkParms := false; {assume we won't need to check for parameter type errors} StackDeclarations(varParmList); {stack the type records} while typeStack <> nil do begin {reverse the type stack} tsPtr := typeStack; typeStack := tsPtr^.next; if isFunction and (not useGlobalPool) then begin tPtr2 := pointer(GMalloc(sizeof(typeRecord))); tPtr2^ := tsPtr^.typeDef^; tPtr2^.saveDisp := 0; end {if} else tPtr2 := tsPtr^.typeDef; dispose(tsPtr); if tPtr^.kind = functionType then PopTable; case tPtr2^.kind of pointerType: begin tPtr2^.pType := tPtr; end; functionType: begin while tPtr^.kind = definedType do tPtr := tPtr^.dType; tPtr2^.fType := tPtr; if tPtr^.kind in [functionType,arrayType] then Error(103); end; arrayType: begin tPtr2^.size := tPtr^.size * tPtr2^.elements; tPtr2^.aType := tPtr; end; otherwise: ; end; {case} tPtr := tPtr2; end; {while} if checkParms then begin {check for parameter type conflicts} with variable^ do begin if doingParameters then begin if itype = nil then begin itype := tPtr; numberOfParameters := numberOfParameters-1; if pfunc^.itype^.prototyped then begin pfunc^.itype^.overrideKR := true; p1 := nil; for i := 1 to bitdisp do begin p2 := pfunc^.itype^.parameterList; while (p2^.next <> p1) and (p2 <> nil) do p2 := p2^.next; p1 := p2; end; {for} compatible := false; if CompTypes(p1^.parameterType, tPtr) then compatible := true else begin tk1 := p1^.parameterType^.kind; tk2 := tPtr^.kind; if (tk1 = arrayType) and (tk2 = pointerType) then compatible := CompTypes(p1^.parameterType^.aType, tPtr^.pType) else if (tk1 = pointerType) and (tk2 = arrayType) then compatible := CompTypes(p1^.parameterType^.pType, tPtr^.aType); end; {else} if not compatible then Error(47); end; {if} end {if} else Error(42); storage := parameter; parameterStorage := true; end; {if} end; {with} end {if} else if doingParameters then if pfunc^.itype^.prototyped then if not doingPrototypes then if tPtr^.kind in [enumConst,structType,unionType,definedType,pointerType] then Error(50); if tPtr^.kind = functionType then begin {declare the identifier} if variable <> nil then begin t1 := variable^.itype; if CompTypes(t1, tPtr) then begin if t1^.prototyped and tPtr^.prototyped then begin p2 := tptr^.parameterList; if isPascal then begin {reverse the parameter list} p1 := nil; while p2 <> nil do begin p3 := p2; p2 := p2^.next; p3^.next := p1; p1 := p3; end; {while} tPtr^.parameterList := p1; end; {if} p2 := tPtr^.parameterList; p1 := t1^.parameterList; while (p1 <> nil) and (p2 <> nil) do begin if p1^.parameter = nil then pt1 := p1^.parameterType else pt1 := p1^.parameter^.itype; if p2^.parameter = nil then pt2 := p2^.parameterType else pt2 := p2^.parameter^.itype; if not CompTypes(pt1, pt2) then begin Error(47); goto 1; end; {if} p1 := p1^.next; p2 := p2^.next; end; {while} if p1 <> p2 then Error(47); p2 := tptr^.parameterList; if isPascal then begin {reverse the parameter list} p1 := nil; while p2 <> nil do begin p3 := p2; p2 := p2^.next; p3^.next := p1; p1 := p3; end; {while} tPtr^.parameterList := p1; end; {if} end; {if} end {if} else Error(42); 1: end; {if} end; {if} if tPtr^.kind = functionType then state := declared; if newName <> nil then {declare the variable} variable := NewSymbol(newName, tPtr, storageClass, space, state) else if unnamedParm then variable^.itype := tPtr else begin if token.kind <> semicolonch then Error(9); variable := nil; end; {else} if variable <> nil then begin if parameterStorage then variable^.storage := parameter; if isForwardDeclared then begin {handle forward declarations} tPtr := variable^.itype; lastWasPointer := false; while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do begin if tPtr^.kind = pointerType then lastWasPointer := true else if tPtr^.kind <> definedType then lastWasPointer := false; tPtr := tPtr^.pType; end; {while} if ((tPtr <> typeSpec) and (not (tPtr^.kind in [structType,unionType]))) then begin Error(107); SkipStatement; end; {if} variable^.isForwardDeclared := true; end; {if} end; {if} end; {Declarator} procedure Initializer (var variable: identPtr); { handle a variable initializer } { } { paramaters: } { variable - ptr to the identifier begin initialized } var bitcount: integer; {# if bits initialized} bitvalue: longint; {bit field initializer value} done: boolean; {for loop termination} errorFound: boolean; {used to remove bad initializations} iPtr,jPtr,kPtr: initializerPtr; {for reversing the list} ip: identList; {used to place an id in the list} luseGlobalPool: boolean; {local copy of useGlobalPool} procedure InitializeBitField; { If bit fields have been initialized, fill them in } { } { Inputs: } { bitcount - # of bits initialized } { bitvalue - value of initializer } var iPtr: initializerPtr; {for creating an initializer entry} begin {InitializeBitField} if bitcount <> 0 then begin {skip if there has been no initializer} { writeln('InitializeBitField; bitcount = ', bitcount:1); {debug} {create the initializer entry} iPtr := pointer(Malloc(sizeof(initializerRecord))); iPtr^.next := variable^.iPtr; variable^.iPtr := iPtr; iPtr^.isConstant := isConstant; iPtr^.count := 1; iPtr^.bitdisp := 0; iPtr^.bitsize := 0; iPtr^.isStruct := false; iPtr^.iVal := bitvalue; if bitcount > 16 then iPtr^.itype := cgULong else if bitcount > 8 then iPtr^.itype := cgUWord else iPtr^.itype := cgUByte; bitcount := 0; {reset the bit field values} bitvalue := 0; end; {if} end; {InitializeBitField} procedure GetInitializerValue (tp: typePtr; bitsize,bitdisp: integer); { get the value of an initializer from a single expression } { } { parameters: } { tp - type of the variable being initialized } { bitsize - size of bit field (0 for non-bit fields) } { bitdisp - disp of bit field; unused if bitsize = 0 } label 1,2,3; var bitmask: longint; {used to add a value to a bit field} bKind: baseTypeEnum; {type of constant} etype: typePtr; {expression type} i: integer; {loop variable} ip: identPtr; {ident in pointer constant} iPtr: initializerPtr; {for creating an initializer entry} kind: tokenEnum; {kind of constant} offset, offset2: longint; {integer offset from a pointer} operator: tokenEnum; {operator for constant pointers} tKind: typeKind; {type of constant} tree: tokenPtr; {for evaluating pointer constants} function Subscript (tree: tokenPtr): typePtr; { handle subscripts in a pointer constant } { } { parameters: } { tree - subscript operators } { } { returns: type of the variable } { } { variables: } { iPtr - initializer location to store the array name } { offset - bytes past the start of the array } var ip: identPtr; {ident pointer} rtree: tokenPtr; {work pointer} tp: typePtr; {for tracking types} select: longint; {selector size} size: longint; {subscript value} begin {Subscript} if tree^.token.kind = uasterisk then begin tree := tree^.left; if tree^.token.kind = plusch then begin rtree := tree^.right; if rtree^.token.kind in [intconst,uintconst] then size := rtree^.token.ival else if rtree^.token.kind in [longconst,ulongconst] then size := rtree^.token.lval else begin Error(18); errorFound := true; end; {else} tp := Subscript(tree^.left); if tp^.kind <> arrayType then Error(47) else begin tp := tp^.atype; offset := offset + size*tp^.size; Subscript := tp; end; {else} end {if} else begin Error(47); errorFound := true; Subscript := wordPtr; end; {else} end {if} else if tree^.token.kind = dotch then begin tp := Subscript(tree^.left); if tp^.kind in [structType,unionType] then begin DoSelection(tp, tree^.right, select); Subscript := expressionType; offset := offset+select; if isBitField then Error(106); end {if} else begin Error(47); errorFound := true; Subscript := wordPtr; end; {else} end {else if} else if tree^.token.kind = ident then begin ip := FindSymbol(tree^.token, allSpaces, false, true); if ip = nil then begin Error(31); errorFound := true; Subscript := wordPtr; iPtr^.pName := @'?'; end {if} else begin Subscript := ip^.itype; iPtr^.pName := ip^.name; end; {else} end {else if} else begin Error(47); errorFound := true; Subscript := wordPtr; end; {else} end; {Subscript} begin {GetInitializerValue} if variable^.storage = stackFrame then Expression(autoInitializerExpression, [commach,rparench,rbracech]) else Expression(initializerExpression, [commach,rparench,rbracech]); if bitsize = 0 then begin iPtr := pointer(Malloc(sizeof(initializerRecord))); iPtr^.next := variable^.iPtr; variable^.iPtr := iPtr; iPtr^.isConstant := isConstant; iPtr^.count := 1; iPtr^.bitdisp := 0; iPtr^.bitsize := 0; iPtr^.isStruct := false; end; {if} etype := expressionType; AssignmentConversion(tp, expressionType, isConstant, expressionValue, false, false); if variable^.storage = external then variable^.storage := global; if isConstant and (variable^.storage in [external,global,private]) then begin if bitsize = 0 then begin iPtr^.iVal := expressionValue; iPtr^.itype := tp^.baseType; InitializeBitField; end; {if} case tp^.kind of scalarType: begin bKind := tp^.baseType; if (bKind in [cgByte..cgULong]) and (etype^.baseType in [cgByte..cgULong]) then begin if bKind in [cgLong,cgULong] then if eType^.baseType = cgUByte then iPtr^.iVal := iPtr^.iVal & $000000FF else if eType^.baseType = cgUWord then iPtr^.iVal := iPtr^.iVal & $0000FFFF; goto 3; end; {if} if bKind in [cgReal,cgDouble,cgComp,cgExtended] then begin if etype^.baseType in [cgByte..cgULong] then iPtr^.rVal := expressionValue else if etype^.baseType in [cgReal,cgDouble,cgComp,cgExtended] then iPtr^.rval := realExpressionValue; goto 3; end; {if} Error(47); errorFound := true; goto 2; 3: if bitsize <> 0 then begin {set up a bit field value} if bitdisp < bitcount then InitializeBitField; bitmask := 0; for i := 1 to bitsize do bitmask := (bitmask << 1) | 1; bitmask := bitmask & expressionValue; for i := 1 to bitdisp do bitmask := bitmask << 1; bitvalue := bitvalue | bitmask; bitcount := bitcount + bitsize; end; {if} end; arrayType: begin if tp^.aType^.kind = scalarType then if tp^.aType^.baseType in [cgByte,cgUByte] then if eType^.baseType = cgString then goto 2; Error(46); errorFound := true; end; pointerType: if etype = stringTypePtr then begin iPtr^.isConstant := true; iPtr^.iType := ccPointer; iPtr^.pval := 0; iPtr^.pPlus := operator = plusch; iPtr^.isName := false; iPtr^.pStr := longstringPtr(expressionValue); end {if} else if etype^.kind = scalarType then if etype^.baseType in [cgByte..cgULong] then if expressionValue = 0 then iPtr^.iType := cgULong else begin Error(47); errorFound := true; end {else} else begin Error(48); errorFound := true; end {else} else if etype^.kind = pointerType then begin iPtr^.iType := cgULong; iPtr^.pval := expressionValue; end {else if} else begin Error(48); errorFound := true; end; {else} structType,enumType: begin Error(46); errorFound := true; end; otherwise: Error(57); end; {case} 2: DisposeTree(initializerTree); end {if} else begin if (tp^.kind = pointerType) or ((tp^.kind = scalarType) and (tp^.baseType in [cgLong,cgULong])) then begin iPtr^.iType := ccPointer; if variable^.storage in [external,global,private] then begin {do pointer constants with + or -} iPtr^.isConstant := true; tree := initializerTree; while tree^.token.kind = castoper do tree := tree^.left; offset := 0; operator := tree^.token.kind; while operator in [plusch,minusch] do begin with tree^.right^.token do if kind in [intConst,longConst] then begin if kind = intConst then offSet2 := ival else offset2 := lval; if operator = plusch then offset := offset + offset2 else offset := offset - offset2; end {if} else begin Error(47); errorFound := true; end; {else} tree := tree^.left; operator := tree^.token.kind; end; {if} kind := tree^.token.kind; if kind = ident then begin {handle names of functions or static arrays} ip := FindSymbol(tree^.token, allSpaces, false, true); if ip = nil then begin Error(31); errorFound := true; end {if} else begin tKind := ip^.itype^.kind; if tKind = functionType then begin if operator in [plusch,minusch] then begin Error(47); errorFound := true; end; {if} end {if} else if (tKind = arrayType) and (ip^.storage in [external,global,private]) then begin offset := offset*ip^.itype^.atype^.size; end {else if} else if tKind = pointerType then begin Error(48); errorFound := true; end {else if} else begin Error(47); errorFound := true; end; {else} iPtr^.pval := offset; iPtr^.pPlus := true; iPtr^.isName := true; iPtr^.pName := ip^.name; end; {if} end {if} else if kind = uand then begin tree := tree^.left; iPtr^.pPlus := operator = plusch; iPtr^.isName := true; if tree^.token.kind = ident then begin ip := FindSymbol(tree^.token, allSpaces, false, true); if ip = nil then begin Error(31); errorFound := true; end {if} else if ip^.storage in [external,global,private] then begin offset := offset*ip^.itype^.size; iPtr^.pName := ip^.name; end {if} else begin Error(47); errorFound := true; end; {else} end {if} else begin tp := Subscript(tree); if offset > 0 then iPtr^.pPlus := true else begin iPtr^.pPlus := false; offset := -offset; end; {else} end; {else} iPtr^.pval := offset; end {else if} else if kind in [dotch,uasterisk] then begin iPtr^.isName := true; tp := Subscript(tree); if offset > 0 then iPtr^.pPlus := true else begin iPtr^.pPlus := false; offset := -offset; end; {else} iPtr^.pval := offset; end {else if} else if kind = stringConst then begin iPtr^.pval := offset; iPtr^.pPlus := operator = plusch; iPtr^.isName := false; iPtr^.pStr := tree^.token.sval; end {else if} else begin Error(47); errorFound := true; end; {else} DisposeTree(initializerTree); goto 1; end; {if} end {if} else if tp^.kind = structType then iPtr^.isStruct := true; {handle auto variables} if bitsize <> 0 then begin iPtr := pointer(Malloc(sizeof(initializerRecord))); iPtr^.next := variable^.iPtr; variable^.iPtr := iPtr; iPtr^.isConstant := isConstant; iPtr^.count := 1; iPtr^.bitdisp := bitdisp; iPtr^.bitsize := bitsize; iPtr^.isStruct := false; end; {if} if variable^.storage in [external,global,private] then begin Error(41); errorFound := true; end; {else} iPtr^.isConstant := false; iPtr^.iTree := initializerTree; iPtr^.bitdisp := bitdisp; iPtr^.bitsize := bitsize; end; {else} 1: end; {GetInitializerValue} procedure InitializeTerm (tp: typePtr; bitsize,bitdisp: integer; main: boolean); { initialize one level of the type } { } { parameters: } { tp - pointer to the type being initialized } { bitsize - size of bit field (0 for non-bit fields) } { bitdisp - disp of bit field; unused if bitsize = 0 } { main - is this a call from the main level? } var bitCount: integer; {# of bits in a union} braces: boolean; {is the initializer inclosed in braces?} count,maxCount: longint; {for tracking the size of an initializer} ep: tokenPtr; {for forming string expression} iPtr: initializerPtr; {for creating an initializer entry} ip: identPtr; {for tracing field lists} kind: typeKind; {base type of an initializer} ktp: typePtr; {array type with definedTypes removed} procedure Fill (count: longint; tp: typePtr); { fill in unspecified space in an initialized array with 0 } { } { parameters: } { count - ^ elements of this type to create } { tp - ptr to type of elements to create } var i: longint; {loop variable} iPtr: initializerPtr; {for creating an initializer entry} tk: tokenPtr; {expression record} ip: identPtr; {pointer to next field in a structure} begin {Fill} { writeln('Fill tp^.kind = ', ord(tp^.kind):1, '; count = ', count:1); {debug} InitializeBitField; {if needed, do the bit field} if tp^.kind = arrayType then {fill an array} Fill(count*tp^.elements ,tp^.aType) else if tp^.kind = structType then begin {fill a structure} i := count; while i <> 0 do begin ip := tp^.fieldList; while ip <> nil do begin Fill(1, ip^.iType); ip := ip^.next; end; {while} i := i-1; end; {while} end {else if} else if tp^.kind = unionType then {fill a union} Fill(count, tp^.fieldList^.iType) else {fill a single value} while count <> 0 do begin iPtr := pointer(Calloc(sizeof(initializerRecord))); iPtr^.next := variable^.iPtr; variable^.iPtr := iPtr; iPtr^.isConstant := variable^.storage in [external,global,private]; {iPtr^.bitdisp := 0;} {iPtr^.bitsize := 0;} {iPtr^.isStruct := false;} if iPtr^.isConstant then begin if tp^.kind = scalarType then iPtr^.itype := tp^.baseType else if tp^.kind = pointertype then begin iPtr^.itype := cgULong; {iPtr^.iVal := 0;} end {else if} else begin iPtr^.itype := cgWord; Error(47); errorFound := true; end; {else} end {if} else begin new(tk); tk^.next := nil; tk^.left := nil; tk^.middle := nil; tk^.right := nil; tk^.token.kind := intconst; tk^.token.class := intConstant; tk^.token.ival := 0; iPtr^.iTree := tk; end; {else} if count < 16384 then begin iPtr^.count := long(count).lsw; count := 0; end {if} else begin iPtr^.count := 16384; count := count-16384; end; {else} end; {while} end; {Fill} procedure RecomputeSizes (tp: typePtr); { a size has been infered from an initializer - set the } { appropriate type size values } { } { parameters: } { tp - type to check } begin {RecomputeSizes} if tp^.aType^.kind = arrayType then RecomputeSizes(tp^.aType); with tp^ do size := aType^.size*elements; end; {RecomputeSizes} begin {InitializeTerm} braces := false; {allow for an opening brace} if token.kind = lbracech then begin NextToken; braces := true; end; {if} {handle arrays} while tp^.kind = definedType do tp := tp^.dType; kind := tp^.kind; if kind = arrayType then begin ktp := tp^.atype; while ktp^.kind = definedType do ktp := ktp^.dType; kind := ktp^.kind; {handle string constants} if (token.kind = stringConst) and (kind = scalarType) and (ktp^.baseType in [cgByte,cgUByte]) then begin if tp^.elements = 0 then begin tp^.elements := token.sval^.length + 1; RecomputeSizes(variable^.itype); end {if} else if tp^.elements < token.sval^.length then begin Error(44); errorFound := true; end; {else if} with ktp^ do begin iPtr := pointer(Malloc(sizeof(initializerRecord))); iPtr^.next := variable^.iPtr; variable^.iPtr := iPtr; iPtr^.count := 1; iPtr^.bitdisp := 0; iPtr^.bitsize := 0; iPtr^.isStruct := false; if (variable^.storage in [external,global,private]) then begin iPtr^.isConstant := true; iPtr^.itype := cgString; iPtr^.sval := token.sval; count := tp^.elements - token.sval^.length; if count <> 0 then Fill(count, bytePtr); end {if} else begin iPtr^.isConstant := false; new(ep); iPtr^.iTree := ep; ep^.next := nil; ep^.left := nil; ep^.middle := nil; ep^.right := nil; ep^.token := token; end; {else} end; {with} NextToken; end {if} {handle arrays of non-strings} else if kind in [scalarType,pointerType,enumType,arrayType,structType,unionType] then begin count := 0; {get the expressions|initializers} maxCount := tp^.elements; if token.kind <> rbracech then repeat InitializeTerm(ktp, 0, 0, false); count := count+1; if count <> maxCount then begin if token.kind = commach then begin NextToken; done := token.kind = rbracech; end {if} else done := true; end {if} else done := true; until done or (token.kind = eofsy) or (count = maxCount); if maxCount <> 0 then begin count := maxCount-count; if count <> 0 then {if there weren't enough initializers...} Fill(count,ktp); { fill in the blank spots} end {if} else begin tp^.elements := count; {set the array size} RecomputeSizes(variable^.itype); end; {else} end {else if} else begin Error(47); errorFound := true; end; {else} end {if} {handle structures} else if kind = structType then begin if braces or (not main) then begin count := tp^.size; ip := tp^.fieldList; bitCount := 0; while (ip <> nil) and (token.kind <> rbracech) do begin if ip^.isForwardDeclared then ResolveForwardReference(ip); InitializeTerm(ip^.itype, ip^.bitsize, ip^.bitdisp, false); if ip^.bitSize <> 0 then begin bitCount := bitCount + ip^.bitSize; if bitCount > maxBitField then begin count := count - (maxBitField div 8); bitCount := ip^.bitSize; end; {if} end {if} else begin if bitCount > 0 then begin bitCount := (bitCount+7) div 8; count := count-bitCount; bitCount := 0; end; {if} count := count-ip^.itype^.size; end; {else} { writeln('Initializer: ', ip^.bitsize:10, ip^.bitdisp:10, bitCount:10); {debug} ip := ip^.next; if token.kind = commach then begin if ip <> nil then NextToken; end {if} else ip := nil; end; {while} if bitCount > 0 then begin InitializeBitField; bitCount := (bitCount+7) div 8; count := count-bitCount; bitCount := 0; end; {if} if count > 0 then Fill(count, bytePtr); end {if} else {struct assignment initializer} GetInitializerValue(tp, bitsize, bitdisp); end {else if} {handle unions} else if kind = unionType then begin ip := tp^.fieldList; if ip^.isForwardDeclared then ResolveForwardReference(ip); InitializeTerm(ip^.itype, 0, 0, false); count := tp^.size - ip^.itype^.size; if count > 0 then Fill(count, bytePtr); end {else if} {handle single-valued types} else if kind in [scalarType,pointerType,enumType] then GetInitializerValue(tp, bitsize, bitdisp) else begin Error(47); errorFound := true; end; {else} if braces then begin {if there was an opening brace then } if token.kind = commach then { insist on a closing brace } NextToken; if token.kind = rbracech then NextToken else begin Error(23); while not (token.kind in [rbracech,eofsy]) do NextToken; NextToken; errorFound := true; end; {else} end; {if} end; {InitializeTerm} begin {Initializer} bitcount := 0; {set up for bit fields} bitvalue := 0; errorFound := false; {no errors found so far} luseGlobalPool := useGlobalPool; {use global memory for global vars} useGlobalPool := (variable^.storage in [external,global,private]) or useGlobalPool; {make sure a required '{' is there} if not (token.kind in [lbracech,stringConst]) then if variable^.itype^.kind = arrayType then begin Error(27); errorFound := true; end; {if} InitializeTerm(variable^.itype, 0, 0, true); {do the initialization} variable^.state := initialized; {mark the variable as initialized} iPtr := variable^.iPtr; {reverse the initializer list} jPtr := nil; while iPtr <> nil do begin kPtr := iPtr; iPtr := iPtr^.next; kPtr^.next := jPtr; jPtr := kPtr; end; {while} variable^.iPtr := jPtr; if errorFound then {eliminate bad initializers} variable^.state := defined; new(ip); {place the initializer in the list} ip^.next := initializerList; ip^.id := variable; initializerList := ip; useGlobalPool := luseGlobalPool; {restore useGlobalPool} end; {Initializer} procedure TypeSpecifier {doingFieldList,isConstant: boolean}; { handle a type specifier } { } { parameters: } { doingFieldList - are we processing a field list? } { isConstant - did we already find a constsy? } { } { outputs: } { isForwardDeclared - is the field list component } { referenceing a forward struct/union? } { skipDeclarator - for enum,struct,union with no } { declarator } { typespec - type specifier } label 1,2; var done: boolean; {for loop termination} enumVal: integer; {default value for the next enum constant} tPtr: typePtr; {for building types} variable: identPtr; {enumeration variable} structPtr: identPtr; {structure identifier} structTypePtr: typePtr; {structure type} tKind: typeKind; {defining structure or union?} ttoken: tokenType; {temp variable for struct name} lUseGlobalPool: boolean; {local copy of useGlobalPool} globalStruct: boolean; {did we force global pool use?} procedure FieldList (tp: typePtr; kind: typeKind); { handle a field list } { } { parameters } { tp - place to store the type pointer } var bitDisp: integer; {current bit disp} disp: longint; {current byte disp} done: boolean; {for loop termination} fl,tfl,ufl: identPtr; {field list} ldoingParameters: boolean; {local copy of doingParameters} lisForwardDeclared: boolean; {local copy of isForwardDeclared} lstorageClass: tokenEnum; {storage class of the declaration} maxDisp: longint; {for determining union sizes} variable: identPtr; {variable being defined} begin {FieldList} ldoingParameters := doingParameters; {allow fields in K&R dec. area} doingParameters := false; lisForwardDeclared := isForwardDeclared; {stack this value} lStorageClass := storageClass; {don't allow auto in a struct} storageClass := ident; bitDisp := 0; {start allocation from byte 0} disp := 0; maxDisp := 0; fl := nil; {nothing in the field list, yet} {check for no declarations} if not (token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy, floatsy,doublesy,compsy,extendedsy,enumsy,structsy,unionsy,typedefsy, typedef,voidsy,constsy,volatilesy]) then Error(26); {while there are entries in the field list...} while token.kind in [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy, doublesy,compsy,extendedsy,enumsy,structsy,unionsy,typedefsy,typedef, voidsy,constsy,volatilesy] do begin typeSpec := wordPtr; {default type specifier is an integer} TypeSpecifier(true,false); {get the type specifier} if not skipDeclarator then repeat {declare the variables...} variable := nil; if token.kind <> colonch then begin Declarator(typeSpec, variable, fieldListSpace, false); if variable <> nil then {enter the var in the field list} begin tfl := fl; {(check for dups)} while tfl <> nil do begin if tfl^.name^ = variable^.name^ then Error(42); tfl := tfl^.next; end; {while} variable^.next := fl; fl := variable; end; {if} end; {if} if token.kind = colonch then {handle a bit field} begin if kind = unionType then Error(56); NextToken; Expression(arrayExpression,[commach,semicolonch]); if (expressionValue >= maxBitField) or (expressionValue < 0) then begin Error(54); expressionValue := maxBitField-1; end; {if} if (bitdisp+long(expressionValue).lsw > maxBitField) or (long(expressionValue).lsw = 0) then begin disp := disp+((bitDisp+7) div 8); bitdisp := 0; if long(expressionValue).lsw = 0 then if variable <> nil then Error(55); end; {if} if variable <> nil then begin variable^.disp := disp; variable^.bitdisp := bitdisp; variable^.bitsize := long(expressionValue).lsw; bitdisp := bitdisp+long(expressionValue).lsw; end; {if} end {if} else if variable <> nil then begin if bitdisp <> 0 then begin disp := disp+((bitDisp+7) div 8); bitdisp := 0; end {if} else if kind = unionType then disp := 0; variable^.disp := disp; variable^.bitdisp := bitdisp; variable^.bitsize := 0; disp := disp + variable^.itype^.size; if disp > maxDisp then maxDisp := disp; end; {if} if token.kind = commach then {allow repeated declarations} begin NextToken; done := false; end {if} else done := true; until done or (token.kind = eofsy); Match(semicolonch,22); {insist on a closing ';'} end; {while} if fl <> nil then begin ufl := nil; {reverse the field list} while fl <> nil do begin tfl := fl; fl := fl^.next; tfl^.next := ufl; ufl := tfl; end; {while} if kind = structType then begin {return the field list} if bitdisp <> 0 then disp := disp+((bitDisp+7) div 8); tp^.size := disp; end {if} else tp^.size := maxDisp; tp^.fieldList := ufl; end; {if} storageClass := lStorageClass; {restore default storage class} isForwardDeclared := lisForwardDeclared; {restore the forward flag} doingParameters := ldoingParameters; {restore the parameters flag} end; {FieldList} procedure CheckConst; { Check the token to see if it is a const or volatile } begin {CheckConst} while token.kind in [constsy,volatilesy] do begin if token.kind = constsy then isConstant := true else volatile := true; NextToken; end; {while} end; {CheckConst} begin {TypeSpecifier} isForwardDeclared := false; {not doing a forward reference (yet)} skipDeclarator := false; {declarations are required (so far)} CheckConst; case token.kind of unsignedsy: begin {unsigned} NextToken; CheckConst; if token.kind = shortsy then begin NextToken; CheckConst; if token.kind = intsy then begin NextToken; CheckConst; end; {if} typeSpec := uWordPtr; end {if} else if token.kind = longsy then begin NextToken; CheckConst; if token.kind = intsy then begin NextToken; CheckConst; end; {if} typeSpec := uLongPtr; end {else if} else if token.kind = charsy then begin NextToken; CheckConst; typeSpec := uBytePtr; end {else if} else if token.kind = intsy then begin NextToken; CheckConst; if unix_1 then typeSpec := uLongPtr else typeSpec := uWordPtr; end {else if} else begin CheckConst; if unix_1 then typeSpec := uLongPtr else typeSpec := uWordPtr; end; {else if} end; signedsy: begin {signed} NextToken; CheckConst; if token.kind = shortsy then begin NextToken; CheckConst; if token.kind = intsy then begin NextToken; CheckConst; end; {if} typeSpec := wordPtr; end {if} else if token.kind = longsy then begin NextToken; CheckConst; if token.kind = intsy then begin NextToken; CheckConst; end; {if} typeSpec := longPtr; end {else if} else if token.kind = intsy then begin NextToken; CheckConst; if unix_1 then typeSpec := longPtr else typeSpec := wordPtr; end {else if} else if token.kind = charsy then begin NextToken; CheckConst; typeSpec := bytePtr; end; {else if} end; intsy: begin {int} NextToken; CheckConst; if unix_1 then typeSpec := longPtr else typeSpec := wordPtr; end; longsy: begin {long} NextToken; CheckConst; typeSpec := longPtr; if token.kind in [intsy,floatsy] then begin if token.kind = floatsy then typeSpec := doublePtr; NextToken; CheckConst; end {if} else if token.kind = doublesy then begin typeSpec := extendedPtr; NextToken; CheckConst; end; {else if} end; charsy: begin {char} NextToken; CheckConst; typeSpec := uBytePtr; end; shortsy: begin {short} NextToken; CheckConst; if token.kind = intsy then begin NextToken; CheckConst; end; {if} typeSpec := wordPtr; end; floatsy: begin {float} NextToken; CheckConst; typeSpec := realPtr; end; doublesy: begin {double} NextToken; CheckConst; typeSpec := doublePtr; end; compsy: begin {comp} NextToken; CheckConst; typeSpec := compPtr; end; extendedsy: begin {extended} NextToken; CheckConst; typeSpec := extendedPtr; end; voidsy: begin {void} NextToken; CheckConst; typeSpec := voidPtr; end; enumsy: begin {enum} NextToken; {skip the 'enum' token} if token.kind = ident then begin {handle a type definition} variable := FindSymbol(token, tagSpace, true, true); ttoken := token; NextToken; if variable <> nil then if variable^.itype^.kind = enumType then if token.kind <> lbracech then goto 1; tPtr := pointer(Malloc(sizeof(typeRecord))); tPtr^.size := cgWordSize; tPtr^.saveDisp := 0; tPtr^.isConstant := false; tPtr^.kind := enumType; variable := NewSymbol(ttoken.name, tPtr, storageClass, tagSpace, defined); CheckConst; end {if} else if token.kind <> lbracech then Error(9); enumVal := 0; {set the default value} if token.kind = lbracech then begin NextToken; {skip the '{'} repeat {declare the enum constants} tPtr := pointer(Malloc(sizeof(typeRecord))); tPtr^.size := cgWordSize; tPtr^.saveDisp := 0; tPtr^.isConstant := false; tPtr^.kind := enumConst; if token.kind = ident then begin variable := NewSymbol(token.name, tPtr, ident, variableSpace, defined); NextToken; end {if} else Error(9); if token.kind = eqch then begin {handle explicit enumeration values} NextToken; Expression(arrayExpression,[commach,rbracech]); enumVal := long(expressionValue).lsw; if enumVal <> expressionValue then Error(6); end; {if} tPtr^.eval := enumVal; {set the enumeration constant value} enumVal := enumVal+1; {inc the default enumeration value} if token.kind = commach then {next enumeration...} begin done := false; NextToken; end {if} else done := true; until done or (token.kind = eofsy); if token.kind = rbracech then NextToken else begin Error(23); SkipStatement; end; {else} end; {if} 1: skipDeclarator := token.kind = semicolonch; end; structsy, {struct} unionsy: begin {union} globalStruct := false; {we didn't make it global} if token.kind = structsy then {set the type kind to use} tKind := structType else tKind := unionType; structPtr := nil; {no record, yet} structTypePtr := defaultStruct; {use int as a default type} NextToken; {skip 'struct' or 'union'} if token.kind in [ident,typedef] {if there is a struct name then...} then begin {look up the name} structPtr := FindSymbol(token, tagSpace, true, true); ttoken := token; {record the structure name} NextToken; {skip the structure name} if structPtr = nil then begin {if the name hasn't been defined then...} if token.kind <> lbracech then structPtr := FindSymbol(ttoken, tagSpace, false, true); if structPtr <> nil then structTypePtr := structPtr^.itype else begin isForwardDeclared := true; globalStruct := doingParameters and (token.kind <> lbracech); if globalStruct then begin lUseGlobalPool := useGlobalPool; useGlobalPool := true; end; {if} structTypePtr := pointer(Calloc(sizeof(typeRecord))); {structTypePtr^.size := 0;} {structTypePtr^.saveDisp := 0;} {structTypePtr^.isConstant := false;} structTypePtr^.kind := tkind; {structTypePtr^.fieldList := nil;} {structTypePtr^.sName := nil;} structPtr := NewSymbol(ttoken.name, structTypePtr, ident, tagSpace, defined); structTypePtr^.sName := structPtr^.name; end; end {if} {the name has been defined, so...} else if structPtr^.itype^.kind <> tKind then begin Error(42); {it's an error if it's not a struct} structPtr := nil; end {else} else begin {record the existing structure type} structTypePtr := structPtr^.itype; CheckConst; end; {else} end {if} else if token.kind <> lbracech then Error(9); {its an error if there's no name or struct} 2: if token.kind = lbracech then {handle a structure definition...} begin {error if we already have one!} if (structTypePtr <> defaultStruct) and (structTypePtr^.fieldList <> nil) then begin Error(53); structPtr := nil; end; {if} NextToken; {skip the '{'} if structTypePtr = defaultStruct then begin structTypePtr := pointer(Calloc(sizeof(typeRecord))); {structTypePtr^.size := 0;} {structTypePtr^.saveDisp := 0;} {structTypePtr^.isConstant := false;} structTypePtr^.kind := tkind; {structTypePtr^.fieldList := nil;} {structTypePtr^.sName := nil;} end; {if} if structPtr <> nil then structPtr^.itype := structTypePtr; FieldList(structTypePtr,tKind); {define the fields} if token.kind = rbracech then {insist on a closing rbrace} NextToken else begin Error(23); SkipStatement; end; {else} end; {if} if globalStruct then useGlobalPool := lUseGlobalPool; typeSpec := structTypePtr; skipDeclarator := token.kind = semicolonch; end; typedef: begin {named type definition} typeSpec := token.symbolPtr^.itype; NextToken; end; otherwise: ; end; {case} if isconstant then begin {handle a constant type} new(tPtr); if typeSpec^.kind in [structType,unionType] then begin with tPtr^ do begin size := typeSpec^.size; kind := definedType; dType := typeSpec; end; {with} end {if} else tPtr^ := typeSpec^; tPtr^.isConstant := true; typeSpec := tPtr; end; {if} end; {TypeSpecifier} {-- Externally available subroutines ---------------------------} procedure DoDeclaration {doingPrototypes: boolean}; { process a variable or function declaration } { } { parameters: } { doingPrototypes - are we processing a parameter list? } label 1,2,3; var done: boolean; {for loop termination} foundConstsy: boolean; {did we find a constsy?} fName: stringPtr; {for forming uppercase names} i: integer; {loop variable} isAsm: boolean; {has the asm modifier been used?} lDoingParameters: boolean; {local copy of doingParameters} lisPascal: boolean; {local copy of isPascal} lp,tlp,tlp2: identPtr; {for tracing parameter list} ltypeSpec: typePtr; {copy of type specifier} lUseGlobalPool: boolean; {local copy of useGlobalPool} nextPdisp: integer; {for calculating parameter disps} noFDefinitions: boolean; {are function definitions inhibited?} p1,p2,p3: parameterPtr; {for reversing prototyped parameters} variable: identPtr; {pointer to the variable being declared} fnType: typePtr; {function type} segType: integer; {segment type} tp: typePtr; {for tracing type lists} tk: tokenType; {work token} typeFound: boolean; {has some type specifier been found?} procedure CheckArray (v: identPtr; firstVariable: boolean); { make sure all required array sizes are specified } { } { parameters: } { v - pointer to the identifier to check } { firstVariable - can the first array subscript be of a } { non-fixed size? } label 1; var tp: typePtr; {work pointer} begin {CheckArray} if v <> nil then begin {skip check if there's no variable} tp := v^.itype; {initialize the type pointer} while tp <> nil do begin {check all types} if tp^.kind = arrayType then {if it's an array with an unspecified } if tp^.elements = 0 then { size and an unspecified size is not } if not firstVariable then { allowed here, flag an error. } begin Error(49); goto 1; end; {if} firstVariable := false; {unspecified sizes are only allowed in } { the first subscript } case tp^.kind of {next type...} arrayType: tp := tp^.aType; pointerType: begin tp := tp^.pType; firstVariable := true; {(also allowed for pointers to arrays)} end; functionType: tp := tp^.fType; otherwise: tp := nil; end; {case} end; {while} end; {if} 1: end; {CheckArray} procedure SegmentStatement; { compile a segment statement } { } { statement syntax: } { } { 'segment' string-constant [',' 'dynamic'] } var i: integer; {loop variable} len: integer; {segment name length} begin {SegmentStatement} NextToken; if token.kind = stringConst then begin for i := 1 to 10 do begin defaultSegment[i] := chr(0); currentSegment[i] := chr(0); end; {for} len := token.sval^.length; if len > 10 then len := 10; for i := 1 to len do defaultSegment[i] := token.sval^.str[i]; for i := 1 to len do currentSegment[i] := token.sval^.str[i]; FlagPragmas(p_segment); NextToken; if token.kind = commach then begin NextToken; if token.kind = ident then begin if token.name^ = 'dynamic' then segmentKind := $8000 else Error(84); NextToken; end {if} else Error(84); end {if} else segmentKind := 0; Match(semicolonch,22); end {if} else begin Error(83); SkipStatement; end; {else} end; {SegmentStatement} function InPartialList (fName: stringPtr): boolean; { See if the function is in the partial compile list. } { } { If the function is in the list, the function name is } { removed from the list, and true is returned. If not, } { false is returned. } { } { parameters: } { fName - name of the function to check for } label 1,2; var ch: char; {work character} i,j: integer; {loop variable} len: integer; {length of fName} begin {InPartialList} i := partialFileGS.theString.size; {strip trailing blanks} while (i > 0) and (partialFileGS.theString.theString[i] = ' ') do begin partialFileGS.theString.theString[i] := chr(0); i := i-1; end; {while} while partialFileGS.theString.theString[1] = ' ' do {skip leading blanks} for i := 1 to partialFileGS.theString.size do partialFileGS.theString.theString[i] := partialFileGS.theString.theString[i+1]; InPartialList := true; {assume success} i := 1; {scan the name list} len := length(fName^); while partialFileGS.theString.theString[i] <> chr(0) do begin for j := 1 to len do begin if partialFileGS.theString.theString[i+j-1] <> fName^[j] then goto 1; end; {for} if partialFileGS.theString.theString[i+len] in [' ', chr(0)] then begin {found a match - remove from list & return} j := i+len; while partialFileGS.theString.theString[j] = ' ' do j := j+1; repeat ch := partialFileGS.theString.theString[j]; partialFileGS.theString.theString[i] := ch; i := i+1; j := j+1; until ch = chr(0); goto 2; end; {if} 1: {no match - skip to next name} while not (partialFileGS.theString.theString[i] in [chr(0), ' ']) do i := i+1; while partialFileGS.theString.theString[i] = ' ' do i := i+1; end; {while} InPartialList := false; {no match found} 2: end; {InPartialList} procedure SkipFunction (isAsm: boolean); { Skip a function body for a partial compile } { } { Parameters: } { isAsm - are we compiling an asm function? } var braceCount: integer; {# of unmatched { chars} doingAsm: boolean; {compiling an asm statement?} begin {SkipFunction} Match(lbracech,27); {skip to the closing rbrackch} braceCount := 1; doingAsm := false; if isAsm then charKinds[ord('#')] := ch_pound; while (not (token.kind = eofsy)) and (braceCount <> 0) do begin if token.kind = asmsy then begin doingAsm := true; charKinds[ord('#')] := ch_pound; end {if} else if token.kind = lbracech then braceCount := braceCount+1 else if token.kind = rbracech then begin braceCount := braceCount-1; if doingAsm then begin doingAsm := false; charKinds[ord('#')] := illegal; end; {if} end; {else if} NextToken; end; {while} nameFound := false; {no pc_nam for the next function (yet)} doingFunction := false; {no longer doing a function} charKinds[ord('#')] := illegal; {# is a preprocessor command} end; {SkipFunction} begin {DoDeclaration} lDoingParameters := doingParameters; {record the status} noFDefinitions := false; {are function definitions inhibited?} typeFound := false; {no explicit type found, yet} foundConstsy := false; {did not find a constsy} if doingPrototypes then {prototypes implies a parm list} doingParameters := true else lastParameter := nil; {init parm list if we're not doing prototypes} isFunction := false; {assume it's not a function} if not doingFunction then {handle any segment statements} while token.kind = segmentsy do SegmentStatement; inhibitHeader := true; {block imbedded includes in headers} if token.kind in [constsy,volatilesy] {handle leading constsy, volatile} then begin while token.kind in [constsy,volatilesy] do begin if token.kind = constsy then foundConstsy := true else volatile := true; NextToken; end; {while} end; {if} storageClass := ident; {handle a StorageClassSpecifier} lUseGlobalPool := useGlobalPool; if token.kind in [autosy,externsy,registersy,staticsy,typedefsy] then begin typeFound := true; storageClass := token.kind; if not doingFunction then if token.kind = autosy then Error(62); if doingParameters then begin if token.kind <> registersy then Error(87); end {if} else if storageClass in [staticsy,typedefsy] then useGlobalPool := true; NextToken; end; {if} isAsm := false; isPascal := false; while token.kind in [pascalsy,asmsy] do begin if token.kind = pascalsy then isPascal := true else isAsm := true; NextToken; end; {while} lisPascal := isPascal; typeSpec := wordPtr; {default type specifier is an integer} if token.kind in {handle a TypeSpecifier/declarator} [unsignedsy,signedsy,intsy,longsy,charsy,shortsy,floatsy,doublesy,compsy, extendedsy,voidsy,enumsy,structsy,unionsy,typedef,volatilesy,constsy] then begin typeFound := true; TypeSpecifier(false,foundConstsy); if not skipDeclarator then begin variable := nil; Declarator(typeSpec, variable, variableSpace, doingPrototypes); if variable = nil then begin inhibitHeader := false; if token.kind = semicolonch then NextToken else begin Error(22); SkipStatement; end; {else} goto 1; end; {if} end; {if} end {if} else begin variable := nil; Declarator (typeSpec, variable, variableSpace, doingPrototypes); if variable = nil then begin inhibitHeader := false; if token.kind = semicolonch then NextToken else begin Error(22); SkipStatement; end; {else} goto 1; end; {if} end; isPascal := lisPascal; {make sure variables have some type info} if isFunction then begin if not typeFound then if (lint & lintNoFnType) <> 0 then Error(104); end {if} else if not typeFound then Error(26); 3: {handle a function declaration} if isFunction then begin if doingParameters then {a function cannot be a parameter} Error(28); fnType := variable^.itype; {get the type of the function} while (fnType <> nil) and (fnType^.kind <> functionType) do case fnType^.kind of arrayType : fnType := fnType^.aType; pointerType: fnType := fnType^.pType; definedType: fnType := fnType^.dType; otherwise : fnType := nil; end; {case} if fnType = nil then begin SkipStatement; goto 1; end; {if} if isPascal then begin {reverse prototyped parameters} p1 := fnType^.parameterList; if p1 <> nil then begin p2 := nil; while p1 <> nil do begin p3 := p1; p1 := p1^.next; p3^.next := p2; p2 := p3; end; {while} fnType^.parameterList := p2; end; {if} end; {if} {handle functions in the parameter list} if doingPrototypes then PopTable {external or forward declaration} else if (storageClass = externsy) or (token.kind in [commach,semicolonch,inlinesy]) then begin fnType^.isPascal := isPascal; {note if we have pascal parms} if token.kind = inlinesy then {handle tool declarations} with fnType^ do begin NextToken; Match(lparench,13); if token.kind in [intconst,uintconst] then begin toolNum := token.ival; NextToken; end {if} else Error(18); Match(commach,86); if token.kind in [longconst,ulongconst] then begin dispatcher := token.lval; NextToken; end {if} else if token.kind in [intconst,uintconst] then begin dispatcher := token.ival; NextToken; end {if} else Error(18); Match(rparench,12); end; {with} doingParameters := doingPrototypes; {not doing parms any more} if token.kind = semicolonch then begin inhibitHeader := false; NextToken; {skip the trailing semicolon} end {if} else if (token.kind = commach) and (not doingPrototypes) then begin PopTable; {pop the symbol table} NextToken; {allow further declarations} variable := nil; isFunction := false; Declarator (typeSpec, variable, variableSpace, doingPrototypes); if variable = nil then begin inhibitHeader := false; if token.kind = semicolonch then NextToken else begin Error(22); SkipStatement; end; {else} goto 1; end; {if} goto 3; end {else if} else begin Error(22); SkipStatement; end; {else} PopTable; {pop the symbol table} end {if} {cannot imbed functions...} else if doingFunction then begin isPascal := false; Error(28); while token.kind <> eofsy do NextToken; end {if} {local declaration} else begin if noFDefinitions then Error(22); ftype := fnType^.ftype; {record the type of the function} while fType^.kind = definedType do fType := fType^.dType; variable^.state := defined; {note that the function is defined} pfunc := variable; {set the identifier for parm checks} fnType^.isPascal := isPascal; {note if we have pascal parms} doingFunction := true; {read the parameter list} doingParameters := true; {declare the parameters} lp := lastParameter; {(save now; it's volatile)} while not (token.kind in [lbracech,eofsy]) do if (token.kind in [autosy,externsy,registersy,staticsy,typedefsy, unsignedsy,signedsy,intsy,longsy,charsy,shortsy, floatsy,doublesy,compsy,extendedsy,enumsy, structsy,unionsy,typedef,voidsy,volatilesy, constsy,ident]) then DoDeclaration(false) else begin Error(27); NextToken; end; {else} if numberOfParameters <> 0 then {default K&R parm type is int} begin tlp := lp; while tlp <> nil do begin if tlp^.itype = nil then tlp^.itype := wordPtr; tlp := tlp^.pnext; end; {while} end; {if} tlp := lp; {make sure all parameters have an} while tlp <> nil do { identifier } if tlp^.name^ = '?' then begin Error(113); tlp := nil; end {if} else tlp := tlp^.pnext; doingParameters := false; fName := variable^.name; {skip if this is not needed for a } if doingPartial then { partial compile } if not InPartialList(fName) then begin SkipFunction(isAsm); goto 2; end; {if} TermHeader; {make sure the header file is closed} if progress then {write progress information} writeln('Compiling ', fName^); useGlobalPool := false; {start a local label pool} if not codegenStarted and (liDCBGS.kFlag <> 0) then begin {init the code generator (if it needs it)} CodeGenInit (outFileGS, liDCBGS.kFlag, doingPartial); liDCBGS.kFlag := 3; codegenStarted := true; end; {if} foundFunction := true; {got one...} segType := ord(variable^.class = staticsy) * $4000; if fnType^.isPascal then begin fName := pointer(Malloc(length(variable^.name^)+1)); CopyString(pointer(fName), pointer(variable^.name)); for i := 1 to length(fName^) do if fName^[i] in ['a'..'z'] then fName^[i] := chr(ord(fName^[i]) & $5F); Gen2Name (dc_str, segType, 0, fName); end {if} else Gen2Name (dc_str, segType, 0, variable^.name); doingMain := variable^.name^ = 'main'; firstCompoundStatement := true; Gen0 (dc_pin); if not isAsm then Gen0(pc_ent); nextLocalLabel := 1; {initialize GetLocalLabel} returnLabel := GenLabel; {set up an exit point} tempList := nil; {initialize the work label list} if not isAsm then {generate traceback, profile code} if traceBack or profileFlag then begin if traceBack then nameFound := true; GenPS(pc_nam, variable^.name); end; {if} nextPdisp := 0; {assign displacements to the parameters} if not fnType^.isPascal then begin tlp := lp; lp := nil; while tlp <> nil do begin tlp2 := tlp; tlp := tlp^.pnext; tlp2^.pnext := lp; lp := tlp2; end; {while} end; {if} while lp <> nil do begin lp^.pdisp := nextPdisp; if lp^.itype^.kind = arrayType then nextPdisp := nextPdisp + cgPointerSize else begin if lp^.itype^.kind = scalarType then if lp^.itype^.baseType in [cgReal,cgDouble,cgComp] then {all floating-points are passed as extended} lp^.itype := extendedPtr; nextPdisp := nextPdisp + long(lp^.itype^.size).lsw; if (long(lp^.itype^.size).lsw = 1) and (lp^.itype^.kind = scalarType) then nextPdisp := nextPdisp+1; end; {else} lp := lp^.pnext; end; {while} gotoList := nil; {initialize the label list} {set up struct/union area} if variable^.itype^.ftype^.kind in [structType,unionType] then begin lp := NewSymbol(@'@struct', variable^.itype^.ftype, staticsy, variablespace, declared); tk.kind := ident; tk.class := identifier; tk.name := @'@struct'; tk.symbolPtr := nil; lp := FindSymbol(tk, variableSpace, false, true); Gen1Name(pc_lao, 0, lp^.name); Gen2t(pc_str, 0, 0, cgULong); end; {if} if isAsm then begin AsmFunction(variable); {handle assembly language functions} PopTable; end {if} else begin {generate parameter labels} if fnType^.overrideKR then GenParameters(nil) else GenParameters(fnType^.parameterList); CompoundStatement(false); {process the statements} end; {else} end; {else} 2: ; end {if} {handle a variable declaration} else {if not isFunction then} begin noFDefinitions := true; if not SkipDeclarator then repeat if isPascal then begin tp := variable^.itype; while tp <> nil do case tp^.kind of scalarType, enumType, enumConst, definedType, structType, unionType: begin tp := nil; Error(94); end; arrayType: tp := tp^.atype; pointerType: tp := tp^.pType; functionType: begin tp^.isPascal := true; tp := nil; end; end; {case} end; {if} if token.kind = eqch then begin if storageClass = typedefsy then Error(52); if doingPrototypes then Error(88); NextToken; {handle an initializer} ltypeSpec := typeSpec; Initializer(variable); typeSpec := ltypeSpec; end; {if} {check to insure array sizes are specified} if storageClass <> typedefsy then CheckArray(variable, (storageClass = externsy) or doingParameters); {allocate space} if variable^.storage = stackFrame then begin variable^.lln := GetLocalLabel; Gen2(dc_loc, variable^.lln, long(variable^.itype^.size).lsw); end; {if} if (token.kind = commach) and (not doingPrototypes) then begin done := false; {allow multiple variables on one line} NextToken; variable := nil; Declarator(typeSpec, variable, variableSpace, doingPrototypes); if variable = nil then begin if token.kind = semicolonch then NextToken else begin Error(22); SkipStatement; end; {else} goto 1; end; {if} goto 3; end {if} else done := true; until done or (token.kind = eofsy); if doingPrototypes then begin protoVariable := variable; {make the var available to Declarator} if protoVariable = nil then protoType := typeSpec else protoType := protoVariable^.iType; end {if} else begin inhibitHeader := false; if token.kind = semicolonch then {must end with a semicolon} NextToken else begin Error(22); SkipStatement; end; {else} end; {else} end; {else} 1: doingParameters := lDoingParameters; {restore the status} useGlobalPool := lUseGlobalPool; inhibitHeader := false; end; {DoDeclaration} procedure DoStatement; { process a statement from a function } procedure AutoInit; { initialize auto variables } var count: integer; {initializer counter} ip: identPtr; {pointer to a symbol table entry} lp1,lp2: identList; {used to reverse, track the list} iPtr: initializerPtr; {pointer to the next initializer} procedure Initialize (id: identPtr; disp: longint; itype: typePtr); { initialize a variable } { } { parameters: } { id - pointer to the identifier } { disp - disp past the identifier to initialize } { itype - type of the variable to initialize } { } { variables: } { count - number of times to re-use the initializer } { ip - pointer to the initializer record to use } label 1; var elements: longint; {# array elements} fp: identPtr; {for tracing field lists} size: integer; {fill size} union: boolean; {are we doing a union?} {bit field manipulation} {----------------------} bitcount: integer; {# if bits so far} bitsize,bitdisp: integer; {defines size, location of a bit field} {assignment conversion} {---------------------} tree: tokenPtr; {expression tree} val: longint; {constant expression value} isConstant: boolean; {is the expression a constant?} procedure LoadAddress; { Load the address of the operand } begin {LoadAddress} with id^ do {load the base address} case storage of stackFrame: Gen2(pc_lda, lln, 0); parameter: if itype^.kind = arrayType then Gen2t(pc_lod, pln, 0, cgULong) else Gen2(pc_lda, pln, 0); external, global, private: Gen1Name(pc_lao, 0, name); otherwise: ; end; {case} if disp <> 0 then Gen1t(pc_inc, long(disp).lsw, cgULong) end; {LoadAddress} function ZeroFill (elements: longint; itype: typePtr; count: integer; iPtr: initializerPtr): boolean; { See if an array can be zero filled } { } { parameters: } { elements - elements in the array } { itype - type of each array element } { count - remaining initializer repititions } { iPtr - initializer record } begin {ZeroFill} ZeroFill := false; if not iPtr^.isConstant then if itype^.kind in [scalarType,enumType] then if count >= elements then with iPtr^.itree^ do if token.kind = intconst then if token.ival = 0 then ZeroFill := true; end; {ZeroFill} begin {Initialize} case itype^.kind of scalarType,pointerType,enumType,functionType: begin LoadAddress; {load the destination address} doDispose := count = 1; {generate the expression value} tree := iptr^.itree; {see if this is a constant} {do assignment conversions} while tree^.token.kind = castoper do tree := tree^.left; isConstant := tree^.token.class in [intConstant,longConstant]; if isConstant then if tree^.token.class = intConstant then val := tree^.token.ival else val := tree^.token.lval; { if isConstant then if tree^.token.class = intConstant then Writeln('loc 2: bitsize = ', iPtr^.bitsize:1, '; ival = ', tree^.token.ival:1) {debug} { else Writeln('loc 2: bitsize = ', iPtr^.bitsize:1, '; lval = ', tree^.token.lval:1) {debug} { else Writeln('loc 2: bitsize = ', iPtr^.bitsize:1); {debug} GenerateCode(iptr^.iTree); AssignmentConversion(itype, expressionType, isConstant, val, true, false); case itype^.kind of {save the value} scalarType: if iptr^.bitsize <> 0 then Gen2t(pc_sbf, iptr^.bitdisp, iptr^.bitsize, itype^.basetype) else Gen0t(pc_sto, itype^.baseType); enumType: Gen0t(pc_sto, cgWord); pointerType,functionType: Gen0t(pc_sto, cgULong); end; {case} end; arrayType: begin if itype^.aType^.kind = scalarType then if itype^.aType^.baseType in [cgByte,cgUByte] then if iPtr^.iTree^.token.kind = stringConst then begin GenLdcLong(itype^.elements); Gen0t(pc_stk, cgULong); GenS(pc_lca, iPtr^.iTree^.token.sval); Gen0t(pc_stk, cgULong); Gen0t(pc_bno, cgULong); LoadAddress; Gen0t(pc_stk, cgULong); Gen0t(pc_bno, cgULong); Gen1tName(pc_cup, 0, cgVoid, @'strncpy'); iPtr := iPtr^.next; goto 1; end; {if} elements := itype^.elements; itype := itype^.atype; if ZeroFill(elements, itype, count, iPtr) then begin if itype^.kind = enumType then size := cgWordSize else size := TypeSize(itype^.baseType); size := size * long(elements).lsw; LoadAddress; Gen0t(pc_stk, cgULong); Gen1t(pc_ldc, size, cgWord); Gen0t(pc_stk, cgWord); Gen0t(pc_bno, cgULong); Gen1tName(pc_cup, 0, cgVoid, @'~ZERO'); disp := disp + size; count := count - long(elements).lsw; if count = 0 then begin iPtr := iPtr^.next; count := iPtr^.count; end; {if} end {if} else begin while elements <> 0 do begin Initialize(id, disp, itype); if itype^.kind in [scalarType,pointerType,enumType] then begin count := count-1; if count = 0 then begin iPtr := iPtr^.next; count := iPtr^.count; end; {if} end; {if} disp := disp+itype^.size; elements := elements-1; end; {while} end; {else} 1: end; structType,unionType: begin if iPtr^.isStruct then begin LoadAddress; {load the destination address} GenerateCode(iptr^.iTree); {load the stuct address} {do the assignment} AssignmentConversion(itype, expressionType, isConstant, val, true, false); with expressionType^ do Gen2(pc_mov, long(size).msw, long(size).lsw); Gen0t(pc_pop, UsualUnaryConversions); end {if} else begin union := itype^.kind = unionType; fp := itype^.fieldList; bitsize := iPtr^.bitsize; bitdisp := iPtr^.bitdisp; bitcount := 0; while fp <> nil do begin itype := fp^.itype; { writeln('Initialize: disp = ', disp:3, '; fp^. Disp = ', fp^.disp:3, 'itype^.size = ', itype^.size:1); {debug} { writeln(' bitDisp = ', bitDisp:3, '; fp^.bitDisp = ', fp^.bitDisp:3); {debug} { writeln(' bitSize = ', bitSize:3, '; fp^.bitSize = ', fp^.bitSize:3); {debug} Initialize(id, disp, itype); if bitsize = 0 then begin if bitcount <> 0 then begin disp := disp + (bitcount+7) div 8; bitcount := 0; end {if} else if fp^.bitSize <> 0 then begin bitcount := 8; while (fp <> nil) and (bitcount > 0) do begin bitcount := bitcount - fp^.bitSize; if bitcount > 0 then if fp^.next <> nil then if fp^.next^.bitSize <> 0 then fp := fp^.next else bitcount := 0; end; {while} bitcount := 0; disp := disp + 1; end {else if} else disp := disp + itype^.size; end {if} else if fp^.bitSize = 0 then begin bitsize := 0; disp := disp + itype^.size; end {else if} else begin if bitsize + bitdisp < bitcount then disp := disp + (bitcount + 7) div 8; bitcount := bitsize + bitdisp; end; {else} if itype^.kind in [scalarType,pointerType,enumType] then begin count := count-1; if count = 0 then begin iPtr := iPtr^.next; count := iPtr^.count; bitsize := iPtr^.bitsize; bitdisp := iPtr^.bitdisp; end; {if} end; {if} if union then fp := nil else fp := fp^.next; end; {while} end; {else} end; otherwise: Error(57); end; {case} end; {Initialize} begin {AutoInit} lp1 := nil; {reverse the list} while initializerList <> nil do begin lp2 := initializerList; initializerList := lp2^.next; lp2^.next := lp1; lp1 := lp2; end; {while} while lp1 <> nil do begin {initialize the variables} ip := lp1^.id; iPtr := ip^.iPtr; count := iPtr^.count; if ip^.class <> staticsy then Initialize(ip, 0, ip^.itype); lp2 := lp1; lp1 := lp1^.next; dispose(lp2); end; {while} end; {AutoInit} begin {DoStatement} case statementList^.kind of compoundSt: begin if token.kind = rbracech then begin if statementList^.doingDeclaration then if initializerList <> nil then AutoInit; EndCompoundStatement; end {if} else if (statementList^.doingDeclaration = true) and (token.kind in [autosy,externsy,registersy,staticsy,typedefsy, unsignedsy,signedsy,intsy,longsy,charsy,shortsy, floatsy,doublesy,compsy,extendedsy,enumsy, structsy,unionsy,typedef,voidsy,volatilesy, constsy]) then DoDeclaration(false) else begin if statementList^.doingDeclaration then begin statementList^.doingDeclaration := false; if firstCompoundStatement then begin Gen1Name(dc_sym, ord(doingMain), pointer(table)); firstCompoundStatement := false; end; {if} if initializerList <> nil then AutoInit; end; {if} Statement; end; {else} end; ifSt: EndIfStatement; elseSt: EndElseStatement; doSt: EndDoStatement; whileSt: EndWhileStatement; forSt: EndForStatement; switchSt: EndSwitchStatement; otherwise: Error(57); end; {case} end; {DoStatement} procedure InitParser; { Initialize the parser } begin {InitParser} doingFunction := false; {not doing a function (yet)} doingParameters := false; {not processing parameters} lastLine := 0; {no pc_lnm generated yet} nameFound := false; {no pc_nam generated yet} statementList := nil; {no open statements} codegenStarted := false; {code generator is not started} end; {InitParser} procedure TermParser; { shut down the parser } begin {TermParser} if statementList <> nil then case statementList^.kind of compoundSt : Error(34); doSt : Error(33); elseSt : Error(67); forSt : Error(69); ifSt : Error(32); switchSt : Error(70); whileSt : Error(68); otherwise: Error(57); end; {case} end; {TermParser} end. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..f7f6441 --- /dev/null +++ b/README.md @@ -0,0 +1,18 @@ +# ORCA-C +Apple IIGS ORCA/C Compiler, an ANSI C compiler for the 65816 with libraries for the Apple IIGS + +If you would like to make changes to this compiler and distribute them to others, feel free to submit them here. If the changes apply to compilation on and for an Apple IIGS, they will generally be approved for distribution on the master branch unless the changes deviate significantly from the ANSI C standard. For changes that deviate form ANSI C or changes that retarget the compiler to run on a different platform or generate code for a different platform, the project will either be forked or a new repository will be created, as appropriate. + +The general conditions that must be met before a change is released on master are: + +1. The modified compiler must compile under the currently released version of ORCA/M and ORCA/Pascal. + +2. All samples from the original ORCA/C distribution must compile and execute under the modified compiler, or the sample must be updated, too. + +3. The compiler must pass the ORCA/C tset suite, or the test suite must be suitably modified, too. + +4. The compiler must work with the current ORCA/C libraries, or the libraries must be modified, too. + +Contact support@byteworks.us if you need contributor access. + +A complete distribution of the ORCA languages, including installers and documentation, is available from the Juiced GS store at https://juiced.gs/store/category/software/. It is distributed as part of the Opus ][ package. diff --git a/Scanner.asm b/Scanner.asm new file mode 100755 index 0000000..4ad3c07 --- /dev/null +++ b/Scanner.asm @@ -0,0 +1 @@ + mcopy scanner.macros **************************************************************** * * Convertsl - Convert a string to a long integer * * Inputs: * str - pointer to the string * * Outputs: * Returns the value. * * Notes: * Assumes the string is valid. * **************************************************************** * Convertsl start val equ 0 return value subroutine (4:str),4 stz val initialize the number to zero stz val+2 lda [str] set X to the number of characters and #$00FF tax ldy #1 Y is the disp into the string lb1 asl val val := val*10 rol val+2 ph2 val+2 lda val asl val rol val+2 asl val rol val+2 adc val sta val pla adc val+2 sta val+2 lda [str],Y add in the new digit and #$000F adc val sta val bcc lb2 inc val+2 lb2 iny next character dex bne lb1 return 4:val end **************************************************************** * * KeyPress - Has a key been presed? * * If a key has not been pressed, this function returns * false. If a key has been pressed, it clears the key * strobe. If the key was an open-apple ., a terminal exit * is performed; otherwise, the function returns true. * **************************************************************** * KeyPress start KeyPressGS kpRec lda kpAvailable beq rts ReadKeyGS rkRec lda rkKey cmp #'.' bne lb1 lda rkModifiers and #$0100 beq lb1 ph2 #4 jsl TermError lb1 lda #1 rts rtl kpRec dc i'3' kpKey ds 2 kpModifiers ds 2 kpAvailable ds 2 rkRec dc i'2' rkKey ds 2 rkModifiers ds 2 end **************************************************************** * * NextCh - Read the next character from the file, skipping comments * * Outputs: * ch - character read * **************************************************************** * NextCh start eofChar equ 0 end of file character eolChar equ 13 end of line character stackFrameSize equ 14 size of the work space maxPath equ 255 max length of a path name fp equ 1 file record pointer; work pointer p1 equ 5 work pointer p2 equ 9 cch equ 13 enum (illegal,ch_special,ch_dash,ch_plus,ch_lt,ch_gt,ch_eq,ch_exc),0 enum (ch_and,ch_bar,ch_dot,ch_white,ch_eol,ch_eof,ch_char,ch_string) enum (ch_asterisk,ch_slash,ch_percent,ch_carot,ch_pound,letter,digit) tsc create stack frame sec sbc #stackFrameSize tcs phd tcd ! {flag for preprocessor check} ! if lastWasReturn then ! lastWasReturn := charKinds[ord(ch)] in [ch_eol,ch_white] ! else ! lastWasReturn := charKinds[ord(ch)] = ch_eol; lda ch asl A tax lda charKinds,X ldy #1 cmp #ch_eol beq pf2 ldx lastWasReturn beq pf1 cmp #ch_white beq pf2 pf1 dey pf2 sty lastWasReturn ! 1: lab1 anop ! if chPtr = eofPtr then begin {flag end of file if we're there} lda chPtr cmp eofPtr bne la1 lda chPtr+2 cmp eofPtr+2 beq la2 la1 brl lb5 la2 anop ! if not lastWasReturn then begin ! lastWasReturn := true; ! needWriteLine := true; ! ch := chr(eolChar); ! goto le2; ! end; {if} lda lastWasReturn bne la3 lda #1 sta lastWasReturn sta needWriteLine lda #eolChar sta ch brl le2 ! ch := chr(eofChar); la3 stz ch ! if needWriteLine then begin {do eol processing} ! WriteLine; ! lineNumber := lineNumber+1; ! firstPtr := chPtr; ! end; {if} lda needWriteLine beq lb1 jsl WriteLine inc lineNumber move4 chPtr,firstPtr lb1 anop ! if fileList = nil then begin lda fileList ora fileList+2 bne lb3 lb2 anop ! skipping := false; sta skipping ! end {if} brl le2 ! else begin lb3 anop ! {purge the current source file} ! with ffDCBGS do begin ! pCount := 5; lda #5 sta ffDCBGS ! action := 7; lda #7 sta ffDCBGS+2 ! name := @includeFileGS.theString lla ffDCBGS+12,includeFileGS+2 ! end; {with} ! FastFileGS(ffDCBGS); FastFileGS ffDCBGS ! fp := fileList; {open the file that included this one} move4 fileList,fp ! fileList := fp^.next; ldy #2 lda [fp] sta fileList lda [fp],Y sta fileList+2 ! includeFileGS := fp^.name; ! sourceFileGS := fp^.sname; add4 fp,#4,p1 add4 fp,#4+maxPath+4,p2 short M ldy #maxPath+3 lb4 lda [p1],Y sta includeFileGS,Y lda [p2],Y sta sourceFileGS,Y dey bpl lb4 long M ! lineNumber := fp^.lineNumber; ldy #4+maxPath+4+maxPath+4 lda [fp],Y sta lineNumber ! ReadFile; jsl ReadFile ! eofPtr := pointer(ord4(bofPtr) + ffDCBGS.fileLength); add4 bofPtr,ffDCBGS+46,eofPtr ! chPtr := pointer(ord4(bofPtr) + fp^.disp); ! includeChPtr := chPtr; ! firstPtr := chPtr; ldy #4+maxPath+4+maxPath+4+2 clc lda bofPtr adc [fp],Y sta chPtr sta firstPtr sta includeChPtr lda bofPtr+2 iny iny adc [fp],Y sta chPtr+2 sta firstPtr+2 sta includeChPtr+2 ! needWriteLine := false; stz needWriteLine ! dispose(fp); ph4 fp jsl ~Dispose ! includeCount := includeCount + 1; inc includeCount ! goto 1; brl lab1 ! end; {if} ! end {if} ! else begin lb5 anop ! ch := chr(chPtr^); {fetch the character} move4 chPtr,p1 lda [p1] and #$00FF sta ch ! if needWriteLine then begin {do eol processing} ! WriteLine; ! lineNumber := lineNumber+1; ! firstPtr := chPtr; ! end; {if} lda needWriteLine beq lb6 jsl WriteLine inc lineNumber move4 chPtr,firstPtr lb6 anop ! needWriteLine := charKinds[ord(ch)] = ch_eol; stz needWriteLine lda ch asl A tax lda charKinds,X cmp #ch_eol bne lb7 inc needWriteLine lb7 anop ! chPtr := pointer(ord4(chPtr) + 1); inc4 chPtr ! 2: if (ch = '\') and (charKinds[chPtr^] = ch_eol) then begin ! chPtr := pointer(ord4(chPtr) + 1); ! DebugCheck; ! needWriteLine := true; ! goto 1; ! end; {if} lab2 lda ch cmp #'\' bne lb8 move4 chPtr,p1 lda [p1] and #$00FF asl A tax lda charKinds,X cmp #ch_eol bne lb8 inc4 chPtr jsr DebugCheck lda #1 sta needWriteLine brl lab1 lb8 anop ! {check for debugger code} ! if needWriteLine then ! DebugCheck; lda needWriteLine beq lb9 jsr DebugCheck lb9 anop ! ! {if it's a comment, skip the comment } ! {characters and return a space. } ! if (not doingstring) and (ch = '/') and (chPtr <> eofPtr) ! and ((chr(chPtr^) = '*') ! or ((chr(chPtr^) = '/') and slashSlashComments))then begin lda doingstring jne lc6 lda ch cmp #'/' jne lc7 lda chPtr cmp eofPtr bne lc1 lda chPtr+2 cmp eofPtr+2 jeq lc6 lc1 move4 chPtr,p1 lda [p1] and #$00FF cmp #'*' beq lc1a cmp #'/' jne lc6 ldx slashSlashComments jeq lc6 ! cch := chr(chPtr^); lc1a sta cch ! chPtr := pointer(ord4(chPtr)+1); {skip the '*' or '/'} inc4 chPtr ! done := false; ! repeat lc2 anop ! if chPtr = eofPtr then {if at eof, we're done} ! done := true lda chPtr cmp eofPtr bne lc2a lda chPtr+2 cmp eofPtr+2 jeq lc5 ! else if (cch = '/') and (chPtr^ = return) then begin lc2a lda cch cmp #'/' bne lc2b ! if charKinds[ord(ch)] = ch_eol then ! done := true ! else ! chPtr := pointer(ord4(chPtr)+1); move4 chPtr,p1 lda [p1] and #$00FF asl A tax lda charKinds,X cmp #ch_eol jeq lc5 inc4 chPtr bra lc2 ! end {else if} ! else begin ! ch := chr(chPtr^); {check for terminating */} lc2b move4 chPtr,p1 lda [p1] and #$00FF sta ch ! if charKinds[ord(ch)] = ch_eol then begin ! WriteLine; ! lineNumber := lineNumber+1; ! firstPtr := pointer(ord4(chPtr)+1); ! end; {if} asl A tax lda charKinds,X cmp #ch_eol bne lc3 jsl WriteLine inc lineNumber add4 chPtr,#1,firstPtr lc3 anop ! chPtr := pointer(ord4(chPtr)+1); inc4 chPtr ! if ch = '*' then ! if (chr(chPtr^) = '/') and (chPtr <> eofPtr) then begin ! chPtr := pointer(ord4(chPtr)+1); ! done := true; ! end; {if} lda ch cmp #'*' jne lc2 lda chPtr cmp eofPtr bne lc4 lda chPtr+2 cmp eofPtr+2 jeq lc2 lc4 move4 chPtr,p1 lda [p1] and #$00FF cmp #'/' jne lc2 inc4 chPtr ! end; {else} ! until done; lc5 anop ! {return a space as the result} ! ch := ' '; lda #' ' sta ch ! end {if} brl le2 ! else if (ch = '?') and (chPtr <> eofPtr) and (chr(chPtr^) = '?') then begin lc6 lda ch lc7 cmp #'?' jne le2 lda chPtr cmp eofPtr bne lc8 lda chPtr+2 cmp eofPtr+2 jeq le2 lc8 move4 chPtr,p1 lda [p1] and #$00FF cmp #'?' jne le2 ! chPtr2 := pointer(ord4(chPtr) + 1); inc4 p1 ! if (chPtr2 <> eofPtr) lda p1 cmp eofPtr bne ld1 lda p1+2 cmp eofPtr+2 beq le2 ld1 anop ! and (chr(chPtr2^) in ['(','<','/','''','=',')','>','!','-']) then begin ! case chr(chPtr2^) of ! '(': ch := '['; lda [p1] and #$00FF cmp #'(' bne ld2 lda #'[' bra le1 ! '<': ch := '{'; ld2 cmp #'<' bne ld3 lda #'{' bra le1 ! '/': ch := '\'; ld3 cmp #'/' bne ld4 lda #'\' bra le1 ! '''': ch := '^'; ld4 cmp #'''' bne ld5 lda #'^' bra le1 ! '=': ch := '#'; ld5 cmp #'=' bne ld6 lda #'#' bra le1 ! ')': ch := ']'; ld6 cmp #')' bne ld7 lda #']' bra le1 ! '>': ch := '}'; ld7 cmp #'>' bne ld8 lda #'}' bra le1 ! '!': ch := '|'; ld8 cmp #'!' bne ld9 lda #'|' bra le1 ! '-': ch := '~'; ld9 cmp #'-' bne le2 lda #'~' ! end; {case} le1 sta ch ! chPtr := pointer(ord4(chPtr2) + 1); add4 chPtr,#2 ! goto 2; brl lab2 ! end; {if} ! end; {if} ! end; {else} le2 anop pld tsc clc adc #stackFrameSize tcs rtl ! end; {NextCh} ; ; Local subroutine ; enum (stop,break,autogo),0 line number debug types ! procedure DebugCheck; ! ! {Check for debugger characters; process if found } ! ! begin {DebugCheck} DebugCheck anop ! if chPtr = eofPtr then ! debugType := stop lda chPtr ldx chPtr+2 cmp eofPtr bne db1 cpx eofPtr+2 bne db1 stz debugType bra db5 ! else if ord(chPtr^) = $07 then begin db1 sta p1 stx p1+2 lda [p1] and #$00FF cmp #$07 bne db2 ! debugType := break lda #break sta debugType bra db3 ! else if ord(chPtr^) = $06 then db2 cmp #$06 bne db4 ! debugType := autoGo; lda #autoGo sta debugType ! chPtr := pointer(ord4(chPtr) + 1); db3 inc4 chPtr ! end {if} bra db5 ! else ! debugType := stop; db4 stz debugType ! end; {DebugCheck} db5 rts end **************************************************************** * * SetDateTime - set up the date/time strings * * Outputs: * dateStr - date * timeStr - time string * **************************************************************** * SetDateTime private pha get the date/time pha pha pha _ReadTimeHex lda 1,S set the minutes xba jsr convert sta time+5 pla set the seconds jsr convert sta time+8 lda 1,S set the hour jsr convert sta time+2 pla set the year xba jsr convert sta date+11 lda 1,S set the day inc A jsr convert sta date+6 pla set the month xba and #$00FF asl A asl A tax lda month,X sta date+2 lda month+1,X sta date+3 pla lla timeStr,time set the addresses lla dateStr,date rtl month dc c'Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec' date dc i'12',c'mmm dd 19yy',i1'0' time dc i'9',c'hh:mm:ss',i1'0' convert and #$00FF ldx #0 cv1 sec sbc #10 bcc cv2 inx bra cv1 cv2 clc adc #10 ora #'0' xba pha txa ora #'0' ora 1,S plx rts end \ No newline at end of file diff --git a/Scanner.debug b/Scanner.debug new file mode 100755 index 0000000..08bebf5 --- /dev/null +++ b/Scanner.debug @@ -0,0 +1 @@ +procedure PrintTokenList (tp: tokenListRecordPtr); {debug} begin if tp <> nil then begin PrintTokenList(tp^.next); PrintToken(tp^.token); end; {if} end; procedure PrintMacroTable; {debug} { print the macro definitions } var i: 0..hashSize; {loop/index variable} mp: macroRecordPtr; {used to trace macro lists} begin {PrintMacroTable} for i := 0 to hashSize do begin mp := macros^[i]; while mp <> nil do begin write(' ', mp^.name^, '(', mp^.parameters:1, ') ['); PrintTokenList(mp^.tokens); writeln(']'); mp := mp^.next; end; {while} end; {for} write('(Press RETURN to continue)'); readln; end; {PrintMacroTable} \ No newline at end of file diff --git a/Scanner.macros b/Scanner.macros new file mode 100755 index 0000000..1ace0d2 --- /dev/null +++ b/Scanner.macros @@ -0,0 +1 @@ + MACRO &LAB _READTIMEHEX &LAB LDX #$0D03 JSL $E10000 MEND MACRO &LAB LLA &AD1,&AD2 &LAB ANOP LCLA &L LCLB &LA AIF S:LONGA,.A REP #%00100000 LONGA ON &LA SETB 1 .A LDA #&AD2 &L SETA C:&AD1 .B STA &AD1(&L) &L SETA &L-1 AIF &L,^B LDA #^&AD2 &L SETA C:&AD1 .C STA 2+&AD1(&L) &L SETA &L-1 AIF &L,^C AIF &LA=0,.D SEP #%00100000 LONGA OFF .D MEND MACRO &lab subroutine &parms,&work &lab anop aif c:&work,.a lclc &work &work setc 0 .a gbla &totallen gbla &worklen &worklen seta &work &totallen seta 0 aif c:&parms=0,.e lclc &len lclc &p lcla &i &i seta c:&parms .b &p setc &parms(&i) &len amid &p,2,1 aif "&len"=":",.c &len amid &p,1,2 &p amid &p,4,l:&p-3 ago .d .c &len amid &p,1,1 &p amid &p,3,l:&p-2 .d &p equ &totallen+3+&work &totallen seta &totallen+&len &i seta &i-1 aif &i,^b .e tsc sec sbc #&work tcs inc a phd tcd mend MACRO &lab return &r &lab anop lclc &len aif c:&r,.a lclc &r &r setc 0 &len setc 0 ago .h .a &len amid &r,2,1 aif "&len"=":",.b &len amid &r,1,2 &r amid &r,4,l:&r-3 ago .c .b &len amid &r,1,1 &r amid &r,3,l:&r-2 .c aif &len<>2,.d ldy &r ago .h .d aif &len<>4,.e ldx &r+2 ldy &r ago .h .e aif &len<>10,.g aif &totallen=0,.f lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .f pld tsc clc adc #&worklen+&totallen tcs phb plx ply lda &r+8 pha lda &r+6 pha lda &r+4 pha lda &r+2 pha lda &r pha phy phx plb rtl mexit .g mnote 'Not a valid return length',16 mexit .h aif &totallen=0,.i lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .i pld tsc clc adc #&worklen+&totallen tcs aif &len=0,.j tya .j rtl mend MACRO &LAB PH2 &N1 LCLC &C &LAB ANOP &C AMID &N1,1,1 AIF "&C"="#",.D AIF S:LONGA=1,.A REP #%00100000 .A AIF "&C"<>"{",.B &C AMID &N1,L:&N1,1 AIF "&C"<>"}",.G &N1 AMID &N1,2,L:&N1-2 LDA (&N1) PHA AGO .E .B LDA &N1 PHA AGO .E .D &N1 AMID &N1,2,L:&N1-1 PEA &N1 AGO .F .E AIF S:LONGA=1,.F SEP #%00100000 .F MEXIT .G MNOTE "Missing closing '}'",16 MEND MACRO &LAB ENUM &LIST,&START &LAB ANOP AIF C:&~ENUM,.A GBLA &~ENUM .A AIF C:&START=0,.B &~ENUM SETA &START .B LCLA &CNT &CNT SETA 1 .C &LIST(&CNT) EQU &~ENUM &~ENUM SETA &~ENUM+1 &CNT SETA &CNT+1 AIF &CNT<=C:&LIST,^C MEND MACRO &LAB ADD4 &M1,&M2,&M3 LCLB &YISTWO LCLC &C &LAB ~SETM AIF C:&M3,.A &C AMID "&M2",1,1 AIF "&C"<>"#",.A &C AMID "&M1",1,1 AIF "&C"="{",.A AIF "&C"="[",.A &C AMID "&M2",2,L:&M2-1 AIF &C>=65536,.A CLC ~LDA &M1 ~OP ADC,&M2 ~STA &M1 BCC ~&SYSCNT ~OP.H INC,&M1 ~&SYSCNT ANOP AGO .C .A AIF C:&M3,.B LCLC &M3 &M3 SETC &M1 .B CLC ~LDA &M1 ~OP ADC,&M2 ~STA &M3 ~LDA.H &M1 ~OP.H ADC,&M2 ~STA.H &M3 .C ~RESTM MEND MACRO &LAB ~OP.H &OPC,&OP &LAB ANOP LCLC &C &C AMID "&OP",1,1 AIF "&C"="[",.B AIF "&C"<>"{",.D &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B AIF &YISTWO,.C &YISTWO SETB 1 LDY #2 &OP SETC "&OP,Y" .C &OPC &OP MEXIT .D AIF "&C"<>"#",.E &OP AMID "&OP",2,L:&OP-1 &OP SETC "#^&OP" &OPC &OP MEXIT .E &OPC 2+&OP MEND MACRO &LAB ~LDA.H &OP &LAB ANOP LCLC &C &C AMID "&OP",1,1 AIF "&C"="[",.B AIF "&C"<>"{",.D &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B AIF &YISTWO,.C &YISTWO SETB 1 LDY #2 &OP SETC "&OP,Y" .C LDA &OP MEXIT .D AIF "&C"<>"#",.E &OP AMID "&OP",2,L:&OP-1 &OP SETC "#^&OP" LDA &OP MEXIT .E LDA 2+&OP MEND MACRO &LAB ~STA.H &OP &LAB ANOP LCLC &C &C AMID "&OP",1,1 AIF "&C"="[",.B AIF "&C"<>"{",.D &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B AIF &YISTWO,.C &YISTWO SETB 1 LDY #2 &OP SETC "&OP,Y" .C STA &OP MEXIT .D STA 2+&OP MEND MACRO &LAB INC4 &A &LAB ~SETM INC &A BNE ~&SYSCNT INC 2+&A ~&SYSCNT ~RESTM MEND MACRO &LAB LONG &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB REP #&M*32+&I*16 AIF .NOT.&M,.B LONGA ON .B AIF .NOT.&I,.C LONGI ON .C MEND MACRO &LAB PH4 &N1 LCLC &C &LAB ANOP &C AMID &N1,1,1 AIF "&C"="#",.D AIF S:LONGA=1,.A REP #%00100000 .A AIF "&C"<>"{",.B &C AMID &N1,L:&N1,1 AIF "&C"<>"}",.G &N1 AMID &N1,2,L:&N1-2 LDY #2 LDA (&N1),Y PHA LDA (&N1) PHA AGO .E .B AIF "&C"<>"[",.C LDY #2 LDA &N1,Y PHA LDA &N1 PHA AGO .E .C LDA &N1+2 PHA LDA &N1 PHA AGO .E .D &N1 AMID &N1,2,L:&N1-1 PEA +(&N1)|-16 PEA &N1 AGO .F .E AIF S:LONGA=1,.F SEP #%00100000 .F MEXIT .G MNOTE "Missing closing '}'",16 MEND MACRO &LAB SHORT &A,&B LCLB &I LCLB &M &A AMID &A,1,1 &M SETB ("&A"="M").OR.("&A"="m") &I SETB ("&A"="I").OR.("&A"="i") AIF C:&B=0,.A &B AMID &B,1,1 &M SETB ("&B"="M").OR.("&B"="m").OR.&M &I SETB ("&B"="I").OR.("&B"="i").OR.&I .A &LAB SEP #&M*32+&I*16 AIF .NOT.&M,.B LONGA OFF .B AIF .NOT.&I,.C LONGI OFF .C MEND MACRO &LAB MOVE4 &F,&T &LAB ~SETM LDA 2+&F STA 2+&T LDA &F STA &T ~RESTM MEND MACRO &LAB JNE &BP &LAB BEQ *+5 BRL &BP MEND MACRO &LAB JEQ &BP &LAB BNE *+5 BRL &BP MEND MACRO &LAB ~SETM &LAB ANOP AIF C:&~LA,.B GBLB &~LA GBLB &~LI .B &~LA SETB S:LONGA &~LI SETB S:LONGI AIF S:LONGA.AND.S:LONGI,.A REP #32*(.NOT.&~LA)+16*(.NOT.&~LI) LONGA ON LONGI ON .A MEND MACRO &LAB ~RESTM &LAB ANOP AIF (&~LA+&~LI)=2,.I SEP #32*(.NOT.&~LA)+16*(.NOT.&~LI) AIF &~LA,.H LONGA OFF .H AIF &~LI,.I LONGI OFF .I MEND MACRO &LAB ~LDA &OP LCLC &C &C AMID "&OP",1,1 AIF "&C"<>"{",.B &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B &LAB LDA &OP MEND MACRO &LAB ~STA &OP LCLC &C &C AMID "&OP",1,1 AIF "&C"<>"{",.B &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B &LAB STA &OP MEND MACRO &LAB ~OP &OPC,&OP LCLC &C &C AMID "&OP",1,1 AIF "&C"<>"{",.B &C AMID "&OP",L:&OP,1 AIF "&C"="}",.A MNOTE "Missing closing '}'",2 &OP SETC &OP} .A &OP AMID "&OP",2,L:&OP-2 &OP SETC (&OP) .B &LAB &OPC &OP MEND macro &l fastfilegs &p &l ~setm jsl $E100A8 dc i2'$014E' dc i4'&p' ~restm mend macro &l keypressgs &p &l ~setm jsl $E100A8 dc i2'$015E' dc i4'&p' ~restm mend macro &l readkeygs &p &l ~setm jsl $E100A8 dc i2'$015F' dc i4'&p' ~restm mend \ No newline at end of file diff --git a/Scanner.pas b/Scanner.pas new file mode 100755 index 0000000..2e534ea --- /dev/null +++ b/Scanner.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Scanner } { } { External Variables: } { } { ch - next character to process } { printMacroExpansions - print the token list? } { reportEOL - report eolsy as a token? } { token - next token to process } { } { External Subroutines: } { } { Error - flag an error } { IsDefined - see if a macro name is in the macro table } { InitScanner - initialize the scanner } { NextCh - Read the next character from the file, skipping } { comments. } { NextToken - read the next token from the file } { PutBackToken - place a token into the token stream } { TermScanner - Shut down the scanner. } { } {---------------------------------------------------------------} unit Scanner; interface {$LibPrefix '0/obj/'} uses CCommon, Table, CGI, MM; {$segment 'scanner'} type pragmas = {kinds of pragmas} (p_startofenum,p_cda,p_cdev,p_float,p_keep, p_nda,p_debug,p_lint,p_memorymodel,p_expand, p_optimize,p_stacksize,p_toolparms,p_databank,p_rtl, p_noroot,p_path,p_ignore,p_segment,p_nba, p_xcmd,p_unix,p_line,p_endofenum); {preprocessor types} {------------------} tokenListRecordPtr = ^tokenListRecord; tokenListRecord = record {element of a list of tokens} next: tokenListRecordPtr; {next element in list} tokenString: longStringPtr; {string making up the token} token: tokenType; {token} expandEnabled: boolean; {can this token be macro expanded?} tokenStart,tokenEnd: ptr; {token start/end markers} end; macroRecordPtr = ^macroRecord; macroRecord = record {preprocessor macro definition} next: macroRecordPtr; saved: boolean; name: stringPtr; parameters: integer; tokens: tokenListRecordPtr; readOnly: boolean; algorithm: integer; end; macroTable = array[0..hashSize] of macroRecordPtr; {preprocessor macro list} {path name lists} {---------------} pathRecordPtr = ^pathRecord; pathRecord = record next: pathRecordPtr; path: stringPtr; end; var ch: char; {next character to process} macros: ^macroTable; {preprocessor macro list} pathList: pathRecordPtr; {addotional search paths} printMacroExpansions: boolean; {print the token list?} reportEOL: boolean; {report eolsy as a token?} skipIllegalTokens: boolean; {skip flagging illegal tokens in skipped code?} slashSlashComments: boolean; {allow // comments?} token: tokenType; {next token to process} {---------------------------------------------------------------} procedure DoDefaultsDotH; { Handle the defaults.h file } procedure Error (err: integer); { flag an error } { } { err - error number } {procedure Error2 (loc, err: integer); {debug} { flag an error } { } { loc - error location } { err - error number } procedure InitScanner (start, endPtr: ptr); { initialize the scanner } { } { start - pointer to the first character in the file } { endPtr - points one byte past the last character in the file } function IsDefined (name: stringPtr): boolean; { See if a macro name is in the macro table } { } { The returned value is true if the macro exists, else false. } { } { parameters: } { name - name of the macro to search for } procedure NextCh; extern; { Read the next character from the file, skipping comments. } { } { Globals: } { ch - character read } procedure NextToken; { Read the next token from the file. } procedure PutBackToken (var token: tokenType; expandEnabled: boolean); { place a token into the token stream } { } { parameters: } { token - token to put back into the token stream } { expandEnabled - can macro expansion be performed? } procedure TermScanner; { Shut down the scanner. } {---------------------------------------------------------------} implementation const {special key values} {------------------} BS = 8; {backspace} FF = 12; {form feed} HT = 9; {horizontal tab} NEWLINE = 10; {newline} RETURN = 13; {RETURN key code} VT = 11; {vertical tab} {misc} {----} defaultName = '13:ORCACDefs:Defaults.h'; {default include file name} maxErr = 10; {max errors on one line} type errorType = record {record of a single error} num: integer; {error number} line: integer; {line number} col: integer; {column number} end; {file inclusion} {--------------} filePtr = ^fileRecord; fileRecord = record {NOTE: used in scanner.asm} next: filePtr; {next file in include stack} name: gsosOutString; {name of the file} sname: gsosOutString; {name of the file for __FILE__} lineNumber: integer; {line number at the #include} disp: longint; {disp of next character to process} end; getFileInfoOSDCB = record pcount: integer; pathName: gsosInStringPtr; access: integer; fileType: integer; auxType: longint; storageType: integer; createDateTime: timeField; modDateTime: timeField; optionList: optionListPtr; dataEOF: longint; blocksUsed: longint; resourceEOF: longint; resourceBlocks: longint; end; expandDevicesDCBGS = record pcount: integer; inName: gsosInStringPtr; outName: gsosOutStringPtr; end; {conditional compilation parsing} {-------------------------------} ifPtr = ^ifRecord; ifRecord = record next: ifPtr; {next record in if stack} status: {what are we doing?} (processing,skippingToEndif,skippingToElse); elseFound: boolean; {has an #else been found?} end; var dateStr: longStringPtr; {macro date string} doingstring: boolean; {used to supress comments in strings} errors: array[1..maxErr] of errorType; {errors in this line} eofPtr: ptr; {points one byte past the last char in the file} fileList: filePtr; {include file list} flagOverflows: boolean; {flag numeric overflows?} gettingFileName: boolean; {are we in GetFileName?} lastWasReturn: boolean; {was the last character an eol?} lineStr: string[5]; {string form of __LINE__} ifList: ifPtr; {points to the top prep. parse record} includeChPtr: ptr; {chPtr at start of current token} includeCount: 0..maxint; {nested include files (for EndInclude)} macroFound: macroRecordPtr; {last macro found by IsDefined} needWriteLine: boolean; {is there a line that needs to be written?} numErr: 0..maxErr; {number of errors in this line} oneStr: string[2]; {string form of __STDC__} ispstring: boolean; {is the current string a p-string?} saveNumber: boolean; {save the characters in a number?} skipping: boolean; {skipping tokens?} timeStr: longStringPtr; {macro time string} tokenColumn: 0..maxint; {column number at start of this token} tokenLine: 0..maxint; {line number at start of this token} tokenList: tokenListRecordPtr; {token putback buffer} tokenStart: ptr; {pointer to the first char in the token} tokenEnd: ptr; {pointer to the first char past the token} versionStrL: longStringPtr; {macro version string} workString: pstring; {for building strings and identifiers} {-- External procedures; see expresssion evaluator for notes ---} procedure EndInclude (chPtr: ptr); extern; { Saves symbols created by the include file } { } { Parameters: } { chPtr - chPtr when the file returned } { } { Notes: } { 1. Call this subroutine right after processing an } { include file. } { 2. Fron Header.pas } procedure ExpandDevicesGS (var parms: expandDevicesDCBGS); prodos ($0154); procedure Expression (kind: expressionKind; stopSym: tokenSet); extern; { handle an expression } function FindSymbol (var tk: tokenType; class: spaceType; oneLevel: boolean; staticAllowed: boolean): identPtr; extern; { locate a symbol in the symbol table } { } { parameters: } { tk - token record for the identifier to find } { class - the kind of variable space to search } { oneLevel - search one level only? (used to check for } { duplicate symbols) } { staticAllowed - can we check for static variables? } { } { returns: } { A pointer to the symbol table entry is returned. If } { there is no entry, nil is returned. } procedure FlagPragmas (pragma: pragmas); extern; { record the effects of a pragma } { } { parameters: } { pragma - pragma to record } { } { Notes: } { 1. From Header.pas } procedure GetFileInfoGS (var parms: getFileInfoOSDCB); prodos ($2006); procedure StartInclude (name: gsosOutStringPtr); extern; { Marks the start of an include file } { } { Notes: } { 1. Call this subroutine right after opening an include } { file. } { 2. From Header.pas } {-- Scanner support --------------------------------------------} procedure CheckDelimiters (var name: pString); { Check for delimiters, making sure they are ':' } { } { parameters: } { name - path name to check } label 1; var dc: char; {delimiter character} i: 0..255; {loop/index variable} begin {CheckDelimiters} dc := ':'; {determine what the delimiter is} for i := 1 to length(name) do if name[i] in [':','/'] then begin dc := name[i]; goto 1; end; {if} 1: ; if dc = '/' then {replace '/' delimiters with ':'} for i := 1 to length(name) do if name[i] = '/' then name[i] := ':'; end; {CheckDelimiters} procedure AddPath (name: pString); { Add a path name to the path name table } { } { parameters: } { name - path name to add } var pp, ppe: pathRecordPtr; {work pointers} begin {AddPath} if length(name) <> 0 then begin CheckDelimiters(name); {make sure ':' is used} if name[length(name)] <> ':' then {make sure there is a trailing delimiter} name := concat(name, ':'); {create the new path record} pp := pathRecordPtr(GMalloc(sizeof(pathRecord))); pp^.next := nil; pp^.path := stringPtr(GMalloc(length(name)+1)); pp^.path^ := name; if pathList = nil then {add the path to the path list} pathList := pp else begin ppe := pathList; while ppe^.next <> nil do ppe := ppe^.next; ppe^.next := pp; end; {else} end; {if} end; {AddPath} function Convertsl(var str: pString): longint; extern; { Return the integer equivalent of the string. Assumes a valid } { 4-byte integer string; supporst unsigned values. } procedure SetDateTime; extern; { set up the macro date/time strings } function KeyPress: boolean; extern; { Has a key been presed? } { } { If a key has not been pressed, this function returns } { false. If a key has been pressed, it clears the key } { strobe. If the key was an open-apple ., a terminal exit } { is performed; otherwise, the function returns true. } function IsDefined {name: stringPtr): boolean}; { See if a macro name is in the macro table } { } { The returned value is true if the macro exists, else false. } { } { parameters: } { name - name of the macro to search for } { } { outputs: } { macroFound - pointer to the macro found } label 1; var bPtr: ^macroRecordPtr; {pointer to hash bucket} mPtr: macroRecordPtr; {for checking list of macros} begin {IsDefined} IsDefined := false; bPtr := pointer(ord4(macros) + Hash(name)); mPtr := bPtr^; while mPtr <> nil do begin if mPtr^.name^ = name^ then begin IsDefined := true; goto 1; end; {if} mPtr := mPtr^.next; end; {while} 1: macroFound := mPtr; end; {IsDefined} procedure PutBackToken {var token: tokenType; expandEnabled: boolean}; { place a token into the token stream } { } { parameters: } { token - token to put back into the token stream } { expandEnabled - can macro expansion be performed? } var tPtr: tokenListRecordPtr; {work pointer} begin {PutBackToken} new(tPtr); tPtr^.next := tokenList; tokenList := tPtr; tPtr^.token := token; tPtr^.expandEnabled := expandEnabled; tPtr^.tokenStart := tokenStart; tPtr^.tokenEnd := tokenEnd; end; {PutBackToken} procedure WriteLine; { Write the current character to the screen. } { } { Global Variables: } { firstPtr - points to the first char in the line } { chPtr - points to the end of line character } var cl: 0..maxint; {column number loop index} cp: ptr; {work pointer} i: 1..maxErr; {error loop index} msg: stringPtr; {pointer to the error message} begin {WriteLine} if list or (numErr <> 0) then begin write(lineNumber:4, ' '); {write the line #} cp := firstPtr; {write the characters in the line} while cp <> chPtr do begin if cp^ <> RETURN then write(chr(cp^)); cp := pointer(ord4(cp) + 1); end; {while} writeln; {write the end of line character} for i := 1 to numErr do {write any errors} with errors[i] do begin if line = lineNumber then begin for cl := 1 to col+4 do write(' '); write('^ '); end {if} else write(' Error in column ', col:1, ' of line ', line:1, ': '); case num of 1 : msg := @'illegal character'; 2 : msg := @'a character constant must contain exactly one character'; 3 : msg := @'no end was found to the string'; 4 : msg := @'further errors suppressed'; 5 : msg := @'cannot redefine a macro'; 6 : msg := @'integer overflow'; 7 : msg := @'''8'' and ''9'' cannot be used in octal constants'; 8 : msg := @'unknown preprocessor command'; 9 : msg := @'identifier expected'; 10: msg := @'cannot undefine standard macros'; 11: msg := @'end of line expected'; 12: msg := @''')'' expected'; 13: msg := @'''('' expected'; 14: msg := @'incorrect number of macro parameters'; 15: msg := @'''>'' expected'; 16: msg := @'file name is too long'; 17: msg := @'keep must appear before any functions'; 18: msg := @'integer constant expected'; 19: msg := @'only one #else may be used per #if'; 20: msg := @'there is no #if for this directive'; 21: msg := @'an #if had no closing #endif'; 22: msg := @''';'' expected'; 23: msg := @'''}'' expected'; 24: msg := @''']'' expected'; 25: msg := @'the else has no matching if'; 26: msg := @'type expected'; 27: msg := @'''{'' expected'; 28: msg := @'a function cannot be defined here'; 29: msg := @''':'' expected'; 30: msg := @'''while'' expected'; 31: msg := @'undeclared identifier'; 32: msg := @'the last if statement was not finished'; 33: msg := @'the last do statement was not finished'; 34: msg := @'the last compound statement was not finished'; 35: msg := @'expression expected'; 36: msg := @'expression syntax error'; 37: msg := @'operand expected'; 38: msg := @'operation expected'; 39: msg := @'no matching ''?'' found for this '':'' operator'; 40: msg := @'illegal type cast'; 41: msg := @'illegal operand in a constant expression'; 42: msg := @'duplicate symbol'; 43: msg := @'the function''s type must match the previous declaration'; 44: msg := @'too many initializers'; 45: msg := @'the number of array elements must be greater than 0'; 46: msg := @'you must initialize the individual elements of a struct, union, or non-char array'; 47: msg := @'type conflict'; 48: msg := @'pointer initializers must resolve to an integer, address or string'; 49: msg := @'the array size could not be determined'; 50: msg := @'only parameters or types may be declared here'; 51: msg := @'lint: undefined function'; 52: msg := @'you cannot initialize a type'; 53: msg := @'the structure has already been defined'; 54: msg := @'bit fields must be less than 32 bits wide'; 55: msg := @'a value cannot be zero bits wide'; 56: msg := @'unions cannot have bit fields'; 57: msg := @'compiler error'; 58: msg := @'implementation restriction: too many local labels'; 59: msg := @'file name expected'; 60: msg := @'implementation restriction: string space exhausted'; 61: msg := @'implementation restriction: run-time stack space exhausted'; 62: msg := @'auto or register can only be used in a function body'; 63: msg := @'token merging produced an illegal token'; 64: msg := @'assignment to an array is not allowed'; 65: msg := @'assignment to void is not allowed'; 66: msg := @'the operation cannot be performed on operands of the type given'; 67: msg := @'the last else clause was not finished'; 68: msg := @'the last while statement was not finished'; 69: msg := @'the last for statement was not finished'; 70: msg := @'the last switch statement was not finished'; 71: msg := @'switch expressions must evaluate to integers'; 72: msg := @'case and default labels must appear in a switch statement'; 73: msg := @'duplicate case label'; 74: msg := @'only one default label is allowed in a switch statement'; 75: msg := @'continue must appear in a while, do or for loop'; 76: msg := @'break must appear in a while, do, for or switch statement'; 77: msg := @'duplicate label'; 78: msg := @'l-value required'; 79: msg := @'illegal operand for the indirection operator'; 80: msg := @'the selection operator must be used on a structure or union'; 81: msg := @'the selected field does not exist in the structure or union'; 82: msg := @'''('', ''['' or ''*'' expected'; 83: msg := @'string constant expected'; 84: msg := @'''dynamic'' expected'; 85: msg := @'the number of parameters does not agree with the prototype'; 86: msg := @''','' expected'; 87: msg := @'invalid storage type for a parameter'; 88: msg := @'you cannot initialize a parameter'; 89: msg := @'''.'' expected'; 90: msg := @'string too long'; 91: msg := @'real constants cannot be unsigned'; 92: msg := @'statement expected'; 93: msg := @'assignment to const is not allowed'; 94: msg := @'pascal qualitfier is only allowed on functions'; 95: msg := @'unidentified operation code'; 96: msg := @'incorrect operand size'; 97: msg := @'operand syntax error'; 98: msg := @'invalid operand'; 99: msg := @'comp data type is not supported by the 68881'; 100: msg := @'integer constants cannot use the f designator'; 101: msg := @'digits expected in the exponent'; {102: msg := @'extern variables cannot be initialized';} 103: msg := @'functions cannot return functions or arrays'; 104: msg := @'lint: missing function type'; 105: msg := @'lint: parameter list not prototyped'; 106: msg := @'cannot take the address of a bit field'; 107: msg := @'illegal use of forward declaration'; 108: msg := @'unknown cc= option on command line'; 109: msg := @'illegal math operation in a constant expression'; 110: msg := @'lint: unknown pragma'; 111: msg := @'the & operator cannot be applied to arrays'; 112: msg := @'segment buffer overflow'; 113: msg := @'all parameters must have a name'; 114: msg := @'a function call was made to a non-function'; otherwise: Error(57); end; {case} writeln(msg^); if terminalErrors then begin if enterEditor then ExitToEditor(msg, ord4(firstPtr)+col-ord4(bofPtr)-1) else TermError(0); end; {if} end; {with} {handle pauses} if ((numErr <> 0) and wait) or KeyPress then begin DrawHourglass; while not KeyPress do {nothing}; ClearHourglass; end; {if} numErr := 0; {no errors on next line...} end {if} else if KeyPress then begin {handle pauses} DrawHourglass; while not KeyPress do {nothing}; ClearHourglass; end; {if} Spin; {twirl the spinner} end; {WriteLine} procedure PrintToken (token: tokenType); { Write a token to standard out } { } { parameters: } { token - token to print } label 1; var ch: char; {work character} i: integer; {loop counter} procedure PrintHexDigit(i: integer); { Print a digit as a hex character } { } { Parameters: } { i: value to print in least significant 4 bits } begin {PrintHexDigit} i := i & $000F; if i < 10 then write(chr(i | ord('0'))) else write(chr(i + ord('A') - 10)); end; {PrintHexDigit} begin {PrintToken} case token.kind of typedef, ident: write(token.name^); intconst, uintconst: write(token.ival:1); longConst, ulongConst: write(token.lval:1); doubleConst: write(token.rval:1); stringConst: begin write('"'); for i := 1 to token.sval^.length do begin ch := token.sval^.str[i]; if ch in [' '..'~'] then write(ch) else begin write('\x0'); PrintHexDigit(ord(ch)>>4); PrintHexDigit(ord(ch)); end; {else} end; {for} write('"'); end; autosy,asmsy,breaksy,casesy,charsy, continuesy,constsy,compsy,defaultsy,dosy, doublesy,elsesy,enumsy,externsy,extendedsy, floatsy,forsy,gotosy,ifsy,intsy, inlinesy,longsy,pascalsy,registersy,returnsy, shortsy,sizeofsy,staticsy,structsy,switchsy, segmentsy,signedsy,typedefsy,unionsy,unsignedsy, voidsy,volatilesy,whilesy: write(reservedWords[token.kind]); tildech,questionch,lparench,rparench,lbrackch,rbrackch,lbracech, rbracech,commach,semicolonch,colonch,poundch: begin for i := minChar to maxChar do if charSym[i] = token.kind then begin write(chr(i)); goto 1; end; {if} end; minusch: write('-'); plusch: write('+'); ltch: write('<'); gtch: write('>'); eqch: write('='); excch: write('!'); andch: write('&'); barch: write('|'); percentch: write('%'); carotch: write('^'); asteriskch: write('*'); slashch: write('/'); dotch: write('.'); minusgtop: write('->'); opplusplus, plusplusop: write('++'); opminusminus, minusminusop: write('--'); ltltop: write('<<'); gtgtop: write('>>'); lteqop: write('<='); gteqop: write('>='); eqeqop: write('=='); exceqop: write('!='); andandop: write('&&'); barbarop: write('||'); pluseqop: write('+='); minuseqop: write('-='); asteriskeqop: write('*='); slasheqop: write('/='); percenteqop: write('%='); ltlteqop: write('<<='); gtgteqop: write('>>='); andeqop: write('&='); caroteqop: write('^='); bareqop: write('!='); uminus: write('-'); uand: write('+'); uasterisk: write('*'); macroParm: write('$', token.pnum:1); poundpoundop, parameteroper, castoper, eolsy, eofsy: ; end; {case} 1: write(' '); end; {PrintToken} { copy 'Scanner.debug'} {debug} {-- The Preprocessor -------------------------------------------} procedure CheckIdentifier; forward; { See if an identifier is a reserved word, macro or typedef } procedure DoNumber (scanWork: boolean); forward; { The current character starts a number - scan it } { } { Parameters: } { scanWork - get characters from workString? } { } { Globals: } { ch - first character in sequence; set to first char } { after sequence } { workString - string to take numbers from } function GetFileType (var name: pString): integer; forward; { Checks to see if a file exists } { } { parameters: } { name - file name to check for } { } { Returns: File type if the file exists, or -1 if the file does } { not exist (or if GetFileInfo returns an error) } function OpenFile (doInclude, default: boolean): boolean; forward; { Open a new file and start scanning it } { } { Parameters: } { doInclude - are we doing a #include? } { default - use the name ? } { } { Returns: result from GetFileName } function FindMacro (name: stringPtr): macroRecordPtr; { If the current token is a macro, find the macro table entry } { } { Parameters: } { name - name of the suspected macro } { } { Returns: } { Pointer to macro table entry; nil for none } label 1; var bPtr: ^macroRecordPtr; {pointer to hash bucket} mPtr: macroRecordPtr; {pointer to macro entry} begin {FindMacro} FindMacro := nil; bPtr := pointer(ord4(macros)+Hash(name)); mPtr := bPtr^; while mPtr <> nil do begin if mPtr^.name^ = name^ then begin if mPtr^.parameters = -1 then FindMacro := mPtr else if tokenList = nil then begin while charKinds[ord(ch)] in [ch_white, ch_eol] do begin if printMacroExpansions then if charKinds[ord(ch)] = ch_eol then writeln else write(ch); NextCh; end; {while} if ch = '(' then FindMacro := mPtr; end {else if} else if tokenList^.token.kind = lparench then FindMacro := mPtr; goto 1; end; {if} mPtr := mPtr^.next; end; {while} 1: end; {FindMacro} procedure LongToPString (pstr: stringPtr; lstr: longStringPtr); { Convert a long string into a p string } { } { Parameters: } { pstr - pointer to the p-string } { lstr - pointer to the long string } var i: integer; {loop variable} len: integer; {string length} begin {LongToPString} len := lstr^.length; if len > 255 then len := 255; pstr^[0] := chr(len); for i := 1 to len do pstr^[i] := lstr^.str[i]; end; {LongToPString} procedure Merge (var tk1: tokenType; tk2: tokenType); { Merge two tokens } { } { Parameters: } { tk1 - first token; result is stored here } { tk2 - second token } label 1; var class1,class2: tokenClass; {token classes} cp: longstringPtr; {pointer to work string} i: integer; {loop variable} kind1,kind2: tokenEnum; {token kinds} len,len1: integer; {length of strings} lt: tokenType; {local copy of token} str1,str2: stringPtr; {identifier strings} begin {Merge} kind1 := tk1.kind; class1 := tk1.class; kind2 := tk2.kind; class2 := tk2.class; if class1 in [identifier,reservedWord] then begin if class1 = identifier then str1 := tk1.name else str1 := @reservedWords[kind1]; if class2 = identifier then str2 := tk2.name else if class2 = reservedWord then str2 := @reservedWords[kind2] else if class2 in [intConstant,longConstant,doubleConstant] then str2 := tk2.numString else begin Error(63); goto 1; end; {else} workString := concat(str1^, str2^); for i := 1 to length(workString) do if not (charKinds[ord(workString[i])] in [letter,digit]) then begin Error(63); goto 1; end; {if} lt := token; token.kind := ident; token.class := identifier; token.numString := nil; token.name := @workString; token.symbolPtr := nil; CheckIdentifier; tk1 := token; token := lt; goto 1; end {class1 in [identifier,reservedWord]} else if class1 in [intConstant,longConstant,doubleConstant] then begin if class2 in [intConstant,longConstant,doubleConstant] then str2 := tk2.numString else if class2 = identifier then str2 := tk2.name else if class2 = reservedWord then str2 := @reservedWords[kind2] else if kind2 = dotch then str2 := @'.' else begin Error(63); goto 1; end; {else} workString := concat(tk1.numString^, str2^); lt := token; DoNumber(true); tk1 := token; token := lt; goto 1; end {else if class1 in [intConstant,longConstant,doubleConstant]} else if class1 = stringConstant then begin if class2 = stringConstant then begin len1 := tk1.sval^.length; len := len1+tk2.sval^.length; cp := pointer(Malloc(len+2)); for i := 1 to len1 do cp^.str[i] := tk1.sval^.str[i]; for i := 1 to len-len1 do cp^.str[i+len1] := tk2.sval^.str[i]; cp^.length := len; if tk1.ispstring then cp^.str[1] := chr(len-1); tk1.sval := cp; goto 1; end; {if} end {else if} else if kind1 = dotch then begin if class2 in [intConstant,longConstant,doubleConstant] then begin workString := concat(tk1.numString^, tk2.numString^); lt := token; DoNumber(true); tk1 := token; token := lt; goto 1; end; {if} end {else if class1 in [intConstant,longConstant,doubleConstant]} else if kind1 = poundch then begin if kind2 = poundch then begin tk1.kind := poundpoundop; goto 1; end; {if} end {else if} else if kind1 = minusch then begin if kind2 = gtch then begin tk1.kind := minusgtop; goto 1; end {if} else if kind2 = minusch then begin tk1.kind := minusminusop; goto 1; end {else if} else if kind2 = eqch then begin tk1.kind := minuseqop; goto 1; end; {else if} end {else if} else if kind1 = plusch then begin if kind2 = plusch then begin tk1.kind := plusplusop; goto 1; end {else if} else if kind2 = eqch then begin tk1.kind := pluseqop; goto 1; end; {else if} end {else if} else if kind1 = ltch then begin if kind2 = ltch then begin tk1.kind := ltltop; goto 1; end {if} else if kind2 = lteqop then begin tk1.kind := ltlteqop; goto 1; end {else if} else if kind2 = eqch then begin tk1.kind := lteqop; goto 1; end; {else if} end {else if} else if kind1 = ltltop then begin if kind2 = eqch then begin tk1.kind := ltlteqop; goto 1; end; {if} end {else if} else if kind1 = gtch then begin if kind2 = gtch then begin tk1.kind := gtgtop; goto 1; end {if} else if kind2 = gteqop then begin tk1.kind := gtgteqop; goto 1; end {else if} else if kind2 = eqch then begin tk1.kind := gteqop; goto 1; end; {else if} end {else if} else if kind1 = gtgtop then begin if kind2 = eqch then begin tk1.kind := gtgteqop; goto 1; end; {if} end {else if} else if kind1 = eqch then begin if kind2 = eqch then begin tk1.kind := eqeqop; goto 1; end; {if} end {else if} else if kind1 = excch then begin if kind2 = eqch then begin tk1.kind := exceqop; goto 1; end; {if} end {else if} else if kind1 = andch then begin if kind2 = andch then begin tk1.kind := andandop; goto 1; end {if} else if kind2 = eqch then begin tk1.kind := andeqop; goto 1; end; {else if} end {else if} else if kind1 = barch then begin if kind2 = barch then begin tk1.kind := barbarop; goto 1; end {if} else if kind2 = eqch then begin tk1.kind := bareqop; goto 1; end; {else if} end {else if} else if kind1 = percentch then begin if kind2 = eqch then begin tk1.kind := percenteqop; goto 1; end; {if} end {else if} else if kind1 = carotch then begin if kind2 = eqch then begin tk1.kind := caroteqop; goto 1; end; {if} end {else if} else if kind1 = asteriskch then begin if kind2 = eqch then begin tk1.kind := asteriskeqop; goto 1; end; {if} end {else if} else if kind1 = slashch then begin if kind2 = eqch then begin tk1.kind := slasheqop; goto 1; end; {if} end; {else if} Error(63); 1: end; {Merge} procedure BuildStringToken (cp: ptr; len: integer); { Create a string token from a string } { } { Used to stringize macros. } { } { Parameters: } { cp - pointer to the first character } { len - number of characters in the string } var i: integer; {loop variable} begin {BuildStringToken} token.kind := stringconst; token.class := stringConstant; token.ispstring := false; token.sval := pointer(GMalloc(len+2)); for i := 1 to len do begin token.sval^.str[i] := chr(cp^); cp := pointer(ord4(cp)+1); end; {for} token.sval^.length := len; PutBackToken(token, true); end; {BuildStringToken} procedure DoInclude (default: boolean); { #include } { } { Parameters: } { default - open ? } var fp: filePtr; {pointer to an include file} begin {DoInclude} new(fp); {get a file record for the current file} fp^.next := fileList; fileList := fp; fp^.name := includeFileGS; fp^.sname := sourceFileGS; fp^.lineNumber := lineNumber+1; if OpenFile(true, default) then begin {open a new file and proceed from there} lineNumber := 1; StartInclude(@includeFileGS); end {if} else begin {handle a file name error} fileList := fp^.next; dispose(fp); end; {else} end; {DoInclude} procedure Expand (macro: macroRecordPtr); { Expand a preprocessor macro } { } { Expands a preprocessor macro by putting tokens from the macro } { definition into the scanner's putback buffer. } { } { Parameters: } { macro - pointer to the macro to expand } { } { Globals: } { macroList - scanner putback buffer } type parameterPtr = ^parameterRecord; parameterRecord = record {parameter list element} next: parameterPtr; {next parameter} tokens: tokenListRecordPtr; {token list} tokenStart,tokenEnd: ptr; {source pointers (for stringization)} end; var bPtr: ^macroRecordPtr; {pointer to hash bucket} done: boolean; {used to check for loop termination} expandEnabled: boolean; {can the token be expanded?} i: integer; {loop counter} inhibit: boolean; {inhibit parameter expansion?} lexpandMacros: boolean; {local copy of expandMacros} lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} mPtr: macroRecordPtr; {for checking list of macros} newParm: parameterPtr; {for building a new parameter entry} tlPtr, tPtr, tcPtr, lastPtr: tokenListRecordPtr; {work pointers} paramCount: integer; {# of parameters found in the invocation} parenCount: integer; {paren count; for balancing parenthesis} parmEnd: parameterPtr; {for building a parameter list} parms: parameterPtr; {points to the list of parameters} pptr: parameterPtr; {work pointer for tracing parms list} sp: longStringPtr; {work pointer} stringization: boolean; {are we stringizing a parameter?} begin {Expand} lPrintMacroExpansions := printMacroExpansions; {inhibit token printing} printMacroExpansions := false; lexpandMacros := expandMacros; {prevent expansion of parameters} expandMacros := false; saveNumber := true; {save numeric strings} parms := nil; {no parms so far} if macro^.parameters >= 0 then begin {find the values of the parameters} NextToken; {get the '(' (we hope...)} if token.kind = lparench then begin NextToken; {skip the '('} paramCount := 0; {process the parameters} parmEnd := nil; repeat done := true; if token.kind <> rparench then begin parenCount := 0; paramCount := paramCount+1; new(newParm); newParm^.next := nil; if parmEnd = nil then parms := newParm else parmEnd^.next := newParm; parmEnd := newParm; newParm^.tokens := nil; while (token.kind <> eofsy) and ((parenCount <> 0) or (not (token.kind in [rparench,commach]))) do begin new(tPtr); tPtr^.next := newParm^.tokens; newParm^.tokens := tPtr; tPtr^.token := token; tPtr^.tokenStart := tokenStart; tPtr^.tokenEnd := tokenEnd; if token.kind = lparench then parenCount := parenCount+1 else if token.kind = rparench then parenCount := parenCount-1; NextToken; end; {while} if token.kind = commach then begin NextToken; done := false; end; {if} end; {if} until done; if paramCount <> macro^.parameters then Error(14); if token.kind = rparench then {insist on a closing ')'} begin if not gettingFileName then NextToken end {if} else Error(12); end {if} else Error(13); if not gettingFileName then {put back the source stream token} PutBackToken(token, true); end; {if} if macro^.readOnly then begin {handle special macros} case macro^.algorithm of 1: begin {__LINE__} token.kind := intconst; token.numString := @lineStr; token.class := intconstant; token.ival := lineNumber; lineStr := cnvis(token.ival); tokenStart := @lineStr[1]; tokenEnd := pointer(ord4(tokenStart)+length(lineStr)); end; 2: begin {__FILE__} token.kind := stringConst; token.class := stringConstant; token.ispstring := false; sp := pointer(Malloc(5+sourceFileGS.theString.size)); sp^.length := sourceFileGS.theString.size; for i := 1 to sourceFileGS.theString.size do sp^.str[i] := sourceFileGS.theString.theString[i]; token.sval := sp; tokenStart := @sp^.str; tokenEnd := pointer(ord4(tokenStart)+sp^.length); end; 3: begin {__DATE__} token.kind := stringConst; token.class := stringConstant; token.ispstring := false; token.sval := dateStr; tokenStart := @dateStr^.str; tokenEnd := pointer(ord4(tokenStart)+dateStr^.length); end; 4: begin {__TIME__} token.kind := stringConst; token.class := stringConstant; token.ispstring := false; token.sval := timeStr; tokenStart := @timeStr^.str; tokenEnd := pointer(ord4(tokenStart)+timeStr^.length); end; 5: begin {__STDC__} token.kind := intConst; {__ORCAC__} token.numString := @oneStr; token.class := intConstant; token.ival := 1; oneStr := '1'; tokenStart := @oneStr[1]; tokenEnd := pointer(ord4(tokenStart)+1); end; 6: begin {__VERSION__} token.kind := stringConst; token.class := stringConstant; token.ispstring := false; token.sval := versionStrL; tokenStart := @versionStrL^.str; tokenEnd := pointer(ord4(tokenStart)+versionStrL^.length); end; otherwise: Error(57); end; {case} PutBackToken(token, true); end {if} else begin {expand the macro} tlPtr := macro^.tokens; {place the tokens in the buffer...} lastPtr := nil; while tlPtr <> nil do begin if tlPtr^.token.kind = macroParm then begin pptr := parms; {find the correct parameter} for i := 1 to tlPtr^.token.pnum do if pptr <> nil then pptr := pptr^.next; if pptr <> nil then begin {see if the macro is stringized} stringization := false; if tlPtr^.next <> nil then stringization := tlPtr^.next^.token.kind = poundch; {handle macro stringization} if stringization then begin tcPtr := pptr^.tokens; while tcPtr <> nil do begin if tcPtr^.token.kind = stringconst then BuildStringToken(@tcPtr^.token.sval^.str, tcPtr^.token.sval^.length) else BuildStringToken(tcPtr^.tokenStart, ord(ord4(tcPtr^.tokenEnd)-ord4(tcPtr^.tokenStart))); tcPtr := tcPtr^.next; end; {while} tlPtr := tlPtr^.next; end {if} {expand a macro parameter} else begin tcPtr := pptr^.tokens; while tcPtr <> nil do begin tokenStart := tcPtr^.tokenStart; tokenEnd := tcPtr^.tokenEnd; if tcPtr^.token.kind = ident then begin mPtr := FindMacro(tcPtr^.token.name); inhibit := false; if tlPtr^.next <> nil then if tlPtr^.next^.token.kind = poundpoundop then inhibit := true; if lastPtr <> nil then if lastPtr^.token.kind = poundpoundop then inhibit := true; if (mPtr <> nil) and (not inhibit) then Expand(mPtr) else PutBackToken(tcPtr^.token, true); end {if} else PutBackToken(tcPtr^.token, true); tcPtr := tcPtr^.next; end; {while} end; {else} end; {if pptr <> nil} end {if tlPtr^.token.kind = macroParm} else begin {place an explicit parm in the token list} expandEnabled := true; if tlPtr^.token.kind = ident then if tlPtr^.token.name^ = macro^.name^ then expandEnabled := false; tokenStart := tlPtr^.tokenStart; tokenEnd := tlPtr^.tokenEnd; PutBackToken(tlPtr^.token, expandEnabled); end; {else} lastPtr := tlPtr; tlPtr := tlPtr^.next; end; {while} end; {else} while parms <> nil do begin {dispose of the parameter list} tPtr := parms^.tokens; while tPtr <> nil do begin tlPtr := tPtr^.next; dispose(tPtr); tPtr := tlPtr; end; {while} parmEnd := parms^.next; dispose(parms); parms := parmEnd; end; {while} expandMacros := lexpandMacros; {restore the flags} printMacroExpansions := lPrintMacroExpansions; saveNumber := false; {stop saving numeric strings} end; {Expand} function GetFileName (mustExist: boolean): boolean; { Read a file name from a directive line } { } { parameters: } { mustExist - should we look for an existing file? } { } { Returns true if successful, false if not. } { } { Note: The file name is placed in workString. } const SRC = $B0; {source file type} var i,j: integer; {string index & loop vars} procedure Expand (var name: pString); { Expands a name to a full pathname } { } { parameters: } { name - file name to expand } var exRec: expandDevicesDCBGS; {expand devices} begin {Expand} exRec.pcount := 2; new(exRec.inName); exRec.inName^.theString := name; exRec.inName^.size := length(name); new(exRec.outName); exRec.outName^.maxSize := maxPath+4; ExpandDevicesGS(exRec); if toolerror = 0 then with exRec.outName^.theString do begin if size < maxPath then theString[size+1] := chr(0); name := theString; end; {with} dispose(exRec.inName); dispose(exRec.outName); end; {Expand} function GetLibraryName (var name: pstring): boolean; { See if a library pathname is available } { } { Parameters: } { name - file name; set to pathname if result is true } { } { Returns: True if a name is available, else false } var lname: pString; {local copy of name} begin {GetLibraryName} lname := concat('13:ORCACDefs:', name); Expand(lname); if GetFileType(lname) = SRC then begin name := lname; GetLibraryName := true; end {if} else GetLibraryName := false; end; {GetLibraryName} function GetLocalName (var name: pstring): boolean; { See if a local pathname is available } { } { Parameters: } { name - file name; set to pathname if result is true } { } { Returns: True if a name is available, else false } var lname: pstring; {work string} pp: pathRecordPtr; {used to trace the path list} begin {GetLocalName} lname := name; Expand(lname); if GetFileType(lname) = SRC then begin GetLocalName := true; name := lname; end {if} else begin GetLocalName := false; pp := pathList; while pp <> nil do begin lname := concat(pp^.path^, name); if GetFileType(lname) = SRC then begin GetLocalName := true; name := lname; Expand(name); pp := nil; end {if} else pp := pp^.next; end; {while} end; {else} end; {GetLocalName} procedure MakeLibraryName (var name: pstring); { Create the library path name for an error message } { } { Parameters: } { name - file name; set to pathname } begin {MakeLibraryName} name := concat('13:ORCACDefs:', name); Expand(name); end; {MakeLibraryName} procedure MakeLocalName (var name: pstring); { Create the local path name for an error message } { } { Parameters: } { name - file name; set to pathname } begin {MakeLocalName} Expand(name); end; {MakeLocalName} begin {GetFileName} GetFileName := true; gettingFileName := true; {in GetFileName} while charKinds[ord(ch)] = ch_white do {finish processing the current line} NextCh; if ch = '<' then begin {process a library file...} NextToken; {skip the '<'} token.kind := stringconst; {convert a <> style name to a string} token.class := stringConstant; token.ispstring := false; i := 0; while not (charKinds[ord(ch)] in [ch_eol,ch_gt]) do begin i := i+1; if (i = maxLine) then begin Error(16); GetFileName := false; i := 0; end; workString[i] := ch; NextCh; end; {while} workString[0] := chr(i); CheckDelimiters(workString); if mustExist then begin if not GetLibraryName(workString) then if not GetLocalName(workString) then MakeLibraryName(workString); end {if} else MakeLibraryName(workString); if ch = '>' then NextCh else begin Error(15); GetFileName := false; end; {else} end {if} else begin {handle file names that are strings or macro expansions} expandMacros := true; {allow macros to be used in the name} NextToken; {skip the command name} if token.kind = stringConst then begin LongToPString(@workString, token.sval); CheckDelimiters(workString); if mustExist then begin if not GetLocalName(workString) then if not GetLibraryName(workString) then MakeLocalName(workString); end {if} else MakeLocalName(workString); end {if} else if token.kind = ltch then begin {expand a macro to create a form name} NextToken; workString[0] := chr(0); while (token.class in [reservedWord,intconstant,longconstant,doubleconstant]) or (token.kind in [dotch,ident]) do begin if token.kind = ident then workstring := concat(workstring, token.name^) else if token.kind = dotch then workstring := concat(workstring, '.') else if token.class = reservedWord then workstring := concat(workstring, reservedWords[token.kind]) else {if token.class in [intconst,longconst,doubleconst] then} workstring := concat(workstring, token.numstring^); NextToken; end; {while} CheckDelimiters(workString); if mustExist then begin if not GetLibraryName(workString) then if not GetLocalName(workString) then MakeLibraryName(workString); end {if} else MakeLibraryName(workString); if token.kind <> gtch then begin Error(15); GetFileName := false; end; {if} end {else if} else begin Error(59); GetFileName := false; end; {else} end; {else} while charKinds[ord(ch)] = ch_white {finish processing the current line} do NextCh; if charKinds[ord(ch)] <> ch_eol then {check for extra stuff on the line} begin Error(11); GetFileName := false; end; {if} gettingFileName := false; {not in GetFileName} end; {GetFileName} function GetFileType {var name: pString): integer}; { Checks to see if a file exists } { } { parameters: } { name - file name to check for } { } { Returns: File type if the file exists, or -1 if the file does } { not exist (or if GetFileInfo returns an error) } var pathname: gsosInString; {GS/OS style name} giRec: getFileInfoOSDCB; {GetFileInfo record} begin {GetFileType} giRec.pcount := 3; giRec.pathName := @pathname; pathname.theString := name; pathname.size := length(name); GetFileInfoGS(giRec); if ToolError = 0 then GetFileType := giRec.fileType else GetFileType := -1; end; {GetFileType} function OpenFile {doInclude, default: boolean): boolean}; { Open a new file and start scanning it } { } { Parameters: } { doInclude - are we doing a #include? } { default - use the name ? } { } { Returns: result from GetFileName } var gotName: boolean; {did we get a file name?} begin {OpenFile} if default then begin {get the file name} workString := defaultName; gotName := true; end {if} else gotName := GetFileName(true); if gotName then begin {read the file name from the line} OpenFile := true; {we opened it} if doInclude and progress then {note our progress} writeln('Including ', workString); WriteLine; {write the source line} lineNumber := lineNumber+1; firstPtr := pointer(ord4(chPtr)+2); needWriteLine := false; if doInclude then {set the disp in the file} fileList^.disp := ord4(chPtr)-ord4(bofPtr); with ffDCBGS do begin {purge the source file} pCount := 5; action := 7; pathName := @includeFileGS.theString; end; {with} FastFileGS(ffDCBGS); oldincludeFileGS := includeFileGS; {set the file name} includeFileGS.theString.theString := workString; includeFileGS.theString.size := length(workString); ReadFile; {read the file} chPtr := bofPtr; {set the start, end pointers} eofPtr := pointer(ord4(bofPtr)+ffDCBGS.fileLength); firstPtr := chPtr; {first char in line} ch := chr(RETURN); {set the initial character} if languageNumber <> long(ffDCBGS.auxType).lsw then begin switchLanguages := true; {switch languages} chPtr := eofPtr; if doInclude then TermError(7); if fileList <> nil then TermError(8); end; {if} end {if} else OpenFile := false; {we failed to opened it} end; {OpenFile} procedure PreProcess; { Handle preprocessor commands } label 2; var lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} lReportEOL: boolean; {local copy of reportEOL} tSkipping: boolean; {temp copy of the skipping variable} val: integer; {expression value} function Defined: boolean; { See if a macro is defined } begin {Defined} expandMacros := false; {block expansions} NextToken; {skip the command name} if token.class in [reservedWord,identifier] then begin Defined := IsDefined(token.name); {see if the macro is defined} expandMacros := true; {enable expansions} NextToken; {skip the macro name} if token.kind <> eolsy then {check for extra stuff on the line} Error(11); end {if} else Error(9); end; {Defined} procedure NumericDirective; { Process a constant expression for a directive that has a } { single number as the operand. } { } { Notes: The expression evaluator returns the value in the } { global variable expressionValue. } begin {NumericDirective} NextToken; {skip the directive name} Expression(preprocessorExpression, []); {evaluate the expression} end; {NumericDirective} procedure ProcessIf (skip: boolean); { handle the processing for #if, #ifdef and #ifndef } { } { parameter: } { skip - should we skip to the #else } var ip: ifPtr; {used to create a new if record} begin {ProcessIf} if token.kind <> eolsy then {check for extra stuff on the line} Error(11); new(ip); {create a new if record} ip^.next := ifList; ifList := ip; if tSkipping then {set the status of the record} ip^.status := skippingToEndif else if skip then ip^.status := skippingToElse else ip^.status := processing; ip^.elseFound := false; {no else has been found...} tSkipping := ip^.status <> processing; {decide if we should be skipping} end; {ProcessIf} procedure DoAppend; { #append } var tbool: boolean; {temp boolean} begin {DoAppend} tbool := OpenFile(false, false); {open a new file and proceed from there} lineNumber := 1; end; {DoAppend} procedure DoCDA; { #pragma cda NAME START SHUTDOWN } begin {DoCDA} FlagPragmas(p_cda); isClassicDeskAcc := true; NextToken; {skip the command name} if token.kind = stringconst then {get the name} begin LongToPString(@menuLine, token.sval); NextToken; end {if} else begin isClassicDeskAcc := false; Error(83); end; {else} if token.kind = ident then begin {get the start name} openName := token.name; NextToken; end {if} else begin isClassicDeskAcc := false; Error(9); end; {else} if token.kind = ident then begin {get the shutdown name} closeName := token.name; NextToken; end {if} else begin isClassicDeskAcc := false; Error(9); end; {else} if token.kind <> eolsy then {make sure there is nothing else on the line} Error(11); end; {DoCDA} procedure DoCDev; { #pragma cdev START } begin {DoCDev} FlagPragmas(p_cdev); isCDev := true; NextToken; {skip the command name} if token.kind = ident then begin {get the start name} openName := token.name; NextToken; end {if} else begin isCDev := false; Error(9); end; {else} if token.kind <> eolsy then {make sure there is nothing else on the line} Error(11); end; {DoCDev} procedure DoDefine; { #define } { } { The way parameters are handled is a bit obtuse. Parameters } { have their own token type, with the token having an } { associated parameter number, pnum. Pnum is the number of } { parameters to skip to get to the parameter in the parameter } { list. } { } { In the macro record, parameters indicates how many } { parameters there are in the definition. -1 indicates that } { there is no parameter list, while 0 indicates that a list } { must exist, but that there are no parameters in the list. } label 1,2,3; type stringListPtr = ^stringList; stringList = record {for the parameter list} next: stringListPtr; str: pString; end; var bPtr: ^macroRecordPtr; {pointer to head of hash bucket} done: boolean; {used to test for loop termination} i: integer; {loop variable} mf: macroRecordPtr; {pointer to existing macro record} mPtr: macroRecordPtr; {pointer to new macro record} np: stringListPtr; {new parameter} parameterList: stringListPtr; {list of parameter names} parameters: integer; {local copy of mPtr^.parameters} ple: stringListPtr; {pointer to the last element in parameterList} pnum: integer; {for counting parameters} tPtr,tk1,tk2: tokenListRecordPtr; {pointer to a token} {for building token strings} sptr: longStringPtr; {token string work pointer} tcp: ptr; {temp character pointer} slen: integer; {token string length} begin {DoDefine} expandMacros := false; {block expansions} saveNumber := true; {save characters in numeric tokens} parameterList := nil; {no parameters yet} NextToken; {get the token name} {convert reserved words to identifiers} if token.class = reservedWord then begin token.name := @reservedWords[token.kind]; token.kind := ident; token.class := identifier; end {if} else if token.kind = typedef then token.kind := ident; if token.kind = ident then begin {we have a name...} mPtr := pointer(GMalloc(sizeof(macroRecord))); {create a macro record} mPtr^.name := token.name; {record the name} mPtr^.saved := false; {not saved in symbol file} mPtr^.tokens := nil; {no tokens yet} charKinds[ord('#')] := ch_pound; {allow # as a token} if ch = '(' then begin {scan the parameter list...} NextToken; {done with the name token...} NextToken; {skip the opening '('} parameters := 0; {no parameters yet} ple := nil; repeat {get the parameter names} done := true; if token.kind = ident then begin new(np); np^.next := nil; np^.str := token.name^; if ple = nil then parameterList := np else ple^.next := np; ple := np; NextToken; parameters := parameters+1; if token.kind = commach then begin NextToken; done := false; end; {if} end; {if} until done; if token.kind = rparench then {insist on a matching ')'} NextToken else Error(12); end {if} else begin parameters := -1; {no parameter list exists} NextToken; {done with the name token...} end; {else} mPtr^.parameters := parameters; {record the # of parameters} while token.kind <> eolsy do begin {place tokens in the replace list...} if token.kind = ident then begin {special handling for identifiers} np := parameterList; {change parameters to macroParm} pnum := 0; while np <> nil do begin if np^.str = token.name^ then begin token.kind := macroParm; token.class := macroParameter; token.pnum := pnum; goto 1; end; {if} pnum := pnum+1; np := np^.next; end; {while} end; {if} 1: tPtr := pointer(GMalloc(sizeof(tokenListRecord))); tPtr^.next := mPtr^.tokens; mPtr^.tokens := tPtr; tPtr^.token := token; tPtr^.tokenStart := tokenStart; tPtr^.tokenEnd := tokenEnd; slen := ord(ord4(chPtr) - ord4(tokenStart)); sptr := pointer(GMalloc(slen+2)); sptr^.length := slen; tcp := tokenStart; for i := 1 to slen do begin sptr^.str[i] := chr(tcp^); tcp := pointer(ord4(tcp)+1); end; {for} tPtr^.tokenString := sptr; NextToken; end; {while} mPtr^.readOnly := false; mPtr^.algorithm := 0; if IsDefined(mPtr^.name) then begin mf := macroFound; if mf^.parameters = mPtr^.parameters then begin tk1 := mf^.tokens; tk2 := mPtr^.tokens; while (tk1 <> nil) and (tk2 <> nil) do begin if tk1^.token.kind <> tk2^.token.kind then goto 3; if tk1^.token.class = tk2^.token.class then case tk1^.token.class of reservedWord, reservedSymbol: ; identifier: if tk1^.token.name^ <> tk2^.token.name^ then goto 3; intConstant: if tk1^.token.ival <> tk2^.token.ival then goto 3; longConstant: if tk1^.token.lval <> tk2^.token.lval then goto 3; doubleConstant: if tk1^.token.rval <> tk2^.token.rval then goto 3; stringConstant: begin if tk1^.token.sval^.length <> tk2^.token.sval^.length then goto 3; for i := 1 to tk1^.token.sval^.length do if tk1^.token.sval^.str[i] <> tk2^.token.sval^.str[i] then goto 3; end; macroParameter: if tk1^.token.pnum <> tk2^.token.pnum then goto 3; otherwise: Error(57); end; {case} tk1 := tk1^.next; tk2 := tk2^.next; end; {while} if (tk1 = nil) and (tk2 = nil) then goto 2; end; {if} 3: Error(5); goto 2; end; {if} {insert the macro in the macro list} bPtr := pointer(ord4(macros) + Hash(mPtr^.name)); mPtr^.next := bPtr^; bPtr^ := mPtr; end {if} else Error(9); {identifier expected} 2: expandMacros := true; {enable expansions} while parameterList <> nil do begin {dump the parameter names} np := parameterList; parameterList := np^.next; dispose(np); end; {while} charKinds[ord('#')] := illegal; {don't allow # as a token} saveNumber := false; {stop saving numeric strings} end; {DoDefine} procedure DoElif; { #elif expression } var ip: ifPtr; {temp; for efficiency} begin {DoElif} ip := ifList; if ip <> nil then begin {decide if we should be skipping} tSkipping := ip^.status <> skippingToElse; if tSkipping then ip^.status := skippingToEndif else begin {evaluate the condition} NumericDirective; {evaluate the condition} if token.kind <> eolsy then {check for extra stuff on the line} Error(11); if expressionValue = 0 then ip^.status := skippingToElse else ip^.status := processing; tSkipping := ip^.status <> processing; {decide if we should be skipping} end; {else} end else Error(20); end; {DoElif} procedure DoElse; { #else } begin {DoElse} NextToken; {skip the command name} if token.kind <> eolsy then {check for extra stuff on the line} Error(11); if ifList <> nil then begin if ifList^.elseFound then {check for multiple elses} Error(19) else ifList^.elseFound := true; {decide if we should be skipping} tSkipping := ifList^.status <> skippingToElse; if tSkipping then {set the status} ifList^.status := skippingToEndif else ifList^.status := processing; end else Error(20); end; {DoElse} procedure DoEndif; { #endif } var ip: ifPtr; {used to create a new if record} begin {DoEndif} NextToken; {skip the command name} if token.kind <> eolsy then {check for extra stuff on the line} Error(11); if ifList <> nil then begin ip := ifList; {remove the top if record from the list} ifList := ip^.next; dispose(ip); if ifList = nil then {decide if we should be skipping} tSkipping := false else tSkipping := ifList^.status <> processing; end {if} else Error(20); end; {DoEndif} procedure DoError; { #error STRING } var i: integer; {loop variable} len: integer; {string length} msg: stringPtr; {error message ptr} begin {DoError} NextToken; {skip the command name} if token.kind = stringConst then begin numErrors := numErrors+1; new(msg); len := token.sval^.length; if len > 246 then len := 246; msg^ := '#error: '; for i := 1 to len do msg^ := concat(msg^, token.sval^.str[i]); writeln(msg^); if terminalErrors then begin if enterEditor then ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr)) else TermError(0); end; {if} end {if} else Error(83); NextToken; {skip the command name} if token.kind <> eolsy then {check for extra stuff on the line} Error(11); end; {DoError} procedure DoFloat; { #pragma float NUMBER NUMBER } begin {DoFloat} FlagPragmas(p_float); NextToken; if token.kind in [intconst,uintconst] then begin floatCard := token.ival; NextToken; end {if} else Error(18); if token.kind in [intconst,uintconst] then begin floatSlot := $C080 | (token.ival << 4); NextToken; end {if} else Error(18); end; {DoFloat} procedure DoKeep; { #pragma keep FILENAME } begin {DoKeep} FlagPragmas(p_keep); if GetFileName(false) then begin {read the file name} if foundFunction then Error(17); if liDCBGS.kFlag = 0 then begin {use the old name if there is one...} liDCBGS.kFlag := 1; outFileGS.theString.theString := workString; outFileGS.theString.size := length(workString); end; {if} end; {if} end; {DoKeep} procedure DoNBA; { #pragma nba MAIN } begin {DoNBA} FlagPragmas(p_nba); isNBA := true; NextToken; {skip the command name} if token.kind = ident then begin {get the open name} openName := token.name; NextToken; end {if} else begin isNBA := false; Error(9); end; {else} if token.kind <> eolsy then {make sure there is nothing else on the line} Error(11); end; {DoNBA} procedure DoNDA; { #pragma nda OPEN CLOSE ACTION INIT PERIOD EVENTMASK MENULINE} function GetInteger: integer; { Get a signed integer constant } var isNegative: boolean; {is the value negative?} value: integer; {value to return} begin {GetInteger} isNegative := false; value := 0; if token.kind = plusch then NextToken else if token.kind = minusch then begin NextToken; isNegative := true; end; {else if} if token.kind in [intconst,uintconst] then begin value := token.ival; NextToken; end {if} else begin isNewDeskAcc := false; Error(18); end; {else} if isNegative then GetInteger := -value else GetInteger := value; end; {GetInteger} begin {DoNDA} FlagPragmas(p_nda); isNewDeskAcc := true; NextToken; {skip the command name} if token.kind = ident then begin {get the open name} openName := token.name; NextToken; end {if} else begin isNewDeskAcc := false; Error(9); end; {else} if token.kind = ident then begin {get the close name} closeName := token.name; NextToken; end {if} else begin isNewDeskAcc := false; Error(9); end; {else} if token.kind = ident then begin {get the action name} actionName := token.name; NextToken; end {if} else begin isNewDeskAcc := false; Error(9); end; {else} if token.kind = ident then begin {get the init name} initName := token.name; NextToken; end {if} else begin isNewDeskAcc := false; Error(9); end; {else} refreshPeriod := GetInteger; {get the period} eventMask := GetInteger; {get the event Mask} if token.kind = stringconst then {get the name} begin LongToPString(@menuLine, token.sval); NextToken; end {if} else begin isNewDeskAcc := false; Error(83); end; {else} if token.kind <> eolsy then {make sure there is nothing else on the line} Error(11); end; {DoNDA} procedure DoUndef; { #undef } label 1; var bPtr: ^macroRecordPtr; {hash bucket pointer} mPtr,lastPtr: macroRecordPtr; {work pointers} begin {DoUndef} expandMacros := false; {block expansions} NextToken; {get the token name} {convert reserved words to identifiers} if token.class = reservedWord then begin token.name := @reservedWords[token.kind]; token.kind := ident; token.class := identifier; end; {if} if token.kind = ident then begin {find the bucket to search} bPtr := pointer(ord4(macros)+Hash(token.name)); lastPtr := nil; {find and delete the macro entry} mPtr := bPtr^; while mPtr <> nil do begin if mPtr^.name^ = token.name^ then begin if mPtr^.readOnly then Error(10) else begin if lastPtr = nil then bPtr^ := mPtr^.next else lastPtr^.next := mPtr^.next; end; {else} goto 1; end; {if} lastPtr := mPtr; mPtr := mPtr^.next; end; {while} end {if} else Error(9); {identifier expected} 1: expandMacros := true; {enable expansions} NextToken; {skip the macro name} if token.kind <> eolsy then {make sure there's no junk on the line} Error(11); end; {DoUndef} procedure DoXCMD; { #pragma xcmd MAIN } begin {DoXCMD} FlagPragmas(p_xcmd); isXCMD := true; NextToken; {skip the command name} if token.kind = ident then begin {get the open name} openName := token.name; NextToken; end {if} else begin isXCMD := false; Error(9); end; {else} if token.kind <> eolsy then {make sure there is nothing else on the line} Error(11); end; {DoXCMD} begin {PreProcess} lPrintMacroExpansions := printMacroExpansions; {inhibit token printing} printMacroExpansions := false; lReportEOL := reportEOL; {we need to see eol's} reportEOL := true; tSkipping := skipping; {don't skip the directive name!} skipping := false; NextCh; {skip the '#' char} while charKinds[ord(ch)] = ch_white do {skip white space} NextCh; if ch in ['a','d','e','i','l','p','u'] then begin NextToken; case token.kind of ifsy: begin NumericDirective; ProcessIf(expressionValue = 0); goto 2; end; elsesy: begin DoElse; goto 2; end; ident: begin case token.name^[1] of 'a': if token.name^ = 'append' then begin if tskipping then goto 2; DoAppend; goto 2; end; {if} 'd': if token.name^ = 'define' then begin if tskipping then goto 2; DoDefine; goto 2; end; {if} 'e': if token.name^ = 'endif' then begin DoEndif; goto 2; end {if} else if token.name^ = 'else' then begin DoElse; goto 2; end {else if} else if token.name^ = 'elif' then begin DoElif; goto 2; end {else if} else if token.name^ = 'error' then begin if tskipping then goto 2; DoError; goto 2; end; {else if} 'i': if token.name^ = 'if' then begin NumericDirective; ProcessIf(expressionValue = 0); goto 2; end {if} else if token.name^ = 'ifdef' then begin ProcessIf(not Defined); goto 2; end {else} else if token.name^ = 'ifndef' then begin ProcessIf(Defined); goto 2; end {else} else if token.name^ = 'include' then begin if tskipping then goto 2; DoInclude(false); goto 2; end; {else} 'l': if token.name^ = 'line' then begin if tskipping then goto 2; FlagPragmas(p_line); NextToken; if token.kind = intconst then begin lineNumber := token.ival; NextToken; end {if} else Error(18); if lineNumber < 0 then lineNumber := 0; if token.kind = stringconst then begin LongToPString( pointer(ord4(@sourceFileGS.theString)+1), token.sval); sourceFileGS.theString.size := token.sval^.length; NextToken; end; {if} if token.kind <> eolsy then Error(11); goto 2; end; {if} 'p': if token.name^ = 'pragma' then begin if tskipping then goto 2; NextToken; if token.name^ = 'keep' then DoKeep else if token.name^ = 'debug' then begin { debug bits: } { 1 - range checking } { 2 - create debug code } { 4 - generate profiles } { 8 - generate traceback code } { 16 - check for stack errors } FlagPragmas(p_debug); NumericDirective; val := long(expressionValue).lsw; rangeCheck := odd(val); debugFlag := odd(val >> 1); profileFlag := odd(val >> 2); traceBack := odd(val >> 3); checkStack := odd(val >> 4); profileFlag := profileFlag or debugFlag; if token.kind <> eolsy then Error(11); goto 2; end {else} else if token.name^ = 'lint' then begin FlagPragmas(p_lint); NumericDirective; lint := long(expressionValue).lsw; if token.kind <> eolsy then Error(11); goto 2; end {else} else if token.name^ = 'memorymodel' then begin FlagPragmas(p_memorymodel); NumericDirective; smallMemoryModel := expressionValue = 0; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'expand' then begin FlagPragmas(p_expand); NumericDirective; lPrintMacroExpansions := expressionValue <> 0; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'optimize' then begin { optimize bits: } { 1 - intermediate code peephole } { 2 - native peephole } { 4 - register value tracking } { 8 - remove stack checks } { 16 - common subexpression elimination } { 32 - loop invariant removal } FlagPragmas(p_optimize); NumericDirective; val := long(expressionValue).lsw; peepHole := odd(val); npeepHole := odd(val >> 1); registers := odd(val >> 2); saveStack := not odd(val >> 3); commonSubexpression := odd(val >> 4); loopOptimizations := odd(val >> 5); strictVararg := not odd(val >> 6); if saveStack or strictVararg then npeepHole := false; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'unix' then begin { unix bits: } { 1 - int is 32 bits } FlagPragmas(p_unix); NumericDirective; val := long(expressionValue).lsw; unix_1 := odd(val); if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'stacksize' then begin FlagPragmas(p_stacksize); NumericDirective; stackSize := long(expressionValue).lsw; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'cda' then DoCDA else if token.name^ = 'cdev' then DoCDev else if token.name^ = 'nda' then DoNDA else if token.name^ = 'nba' then DoNBA else if token.name^ = 'xcmd' then DoXCMD else if token.name^ = 'toolparms' then begin FlagPragmas(p_toolparms); NumericDirective; toolParms := expressionValue <> 0; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'databank' then begin FlagPragmas(p_databank); NumericDirective; dataBank := expressionValue <> 0; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'float' then DoFloat else if token.name^ = 'rtl' then begin FlagPragmas(p_rtl); rtl := true; NextToken; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'noroot' then begin FlagPragmas(p_noroot); noroot := true; NextToken; if token.kind <> eolsy then Error(11); end {else if} { else if token.name^ = 'printmacros' then begin {debug} { PrintMacroTable; NextToken; if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'path' then begin NextToken; if token.kind = stringConst then begin LongToPString(workString, token.sval); AddPath(workString); NextToken; end {if} else Error(83); if token.kind <> eolsy then Error(11); end {else if} else if token.name^ = 'ignore' then begin { ignore bits: } { 1 - don't flag illegal tokens in skipped source } { 8 - allow // comments } FlagPragmas(p_ignore); NumericDirective; val := long(expressionValue).lsw; skipIllegalTokens := odd(val); slashSlashComments := odd(val >> 3); if token.kind <> eolsy then Error(11); end {else if} else if (lint & lintPragmas) <> 0 then Error(110); goto 2; end; {if} 'u': if token.name^ = 'undef' then begin if tskipping then goto 2; DoUndef; goto 2; end; {if} otherwise: Error(57); end; {case} end; otherwise: ; end; {case} end {if} else if charKinds[ord(ch)] = ch_eol {allow null commands} then begin NextToken; goto 2; end; {else if} Error(8); {bad preprocessor command} 2: charKinds[ord('#')] := ch_pound; {allow # as a token} expandMacros := false; {skip to the end of the line} flagOverflows := false; skipping := tSkipping; while not (token.kind in [eolsy,eofsy]) do NextToken; flagOverflows := true; expandMacros := true; charKinds[ord('#')] := illegal; {don't allow # as a token} reportEOL := lReportEOL; {restore flags} printMacroExpansions := lPrintMacroExpansions; skipping := tskipping; end; {PreProcess} {-- Externally available routines ------------------------------} procedure DoDefaultsDotH; { Handle the defaults.h file } var name: pString; {name of the default file} begin {DoDefaultsDotH} name := defaultName; if GetFileType(name) <> -1 then DoInclude(true); end; {DoDefaultsDotH} procedure Error {err: integer}; { flag an error } { } { err - error number } begin {Error} if numErr = maxErr then {set the error number} errors[maxErr].num := 4 else begin numErr := numErr+1; numErrors := numErrors+1; liDCBGS.merrf := 16; errors[numErr].num := err; end; {else} with errors[numErr] do begin {record the position of the error} line := tokenLine; col := tokenColumn; end; {with} codeGeneration := false; {inhibit code generation} end; {Error} {procedure Error2 {loc, err: integer} {debug} { flag an error } { } { loc - error location } { err - error number } {begin {Error2} {writeln('Error ', err:1, ' flagged at location ', loc:1); Error(err); end; {Error2} procedure DoNumber {scanWork: boolean}; { The current character starts a number - scan it } { } { Parameters: } { scanWork - get characters from workString? } { } { Globals: } { ch - first character in sequence; set to first char } { after sequence } { workString - string to take numbers from } label 1; var c2: char; {next character to process} i: integer; {loop index} isHex: boolean; {is the value a hex number?} isLong: boolean; {is the value a long number?} isReal: boolean; {is the value a real number?} numIndex: 0..maxLine; {index into workString} sp: stringPtr; {for saving identifier names} stringIndex: 0..maxLine; {length of the number string} unsigned: boolean; {is the number unsigned?} val: integer; {value of a digit} numString: pString; {characters in the number} procedure NextChar; { Return the next character that is a part of the number } begin {NextChar} if scanWork then begin if ord(workString[0]) <> numIndex then begin numIndex := numIndex+1; c2 := workString[numIndex]; end {if} else c2 := ' '; end {if} else begin NextCh; c2 := ch; end; {else} end; {NextChar} procedure GetDigits; { Read in a digit stream } { } { Variables: } { c2 - next character to process } { numString - digit sequence added to this string } { stringIndex - length of the string } begin {GetDigits} while (charKinds[ord(c2)] = digit) or (isHex and (c2 in ['a'..'f','A'..'F'])) do begin if c2 in ['a'..'f'] then c2 := chr(ord(c2) & $5F); stringIndex := stringIndex+1; if stringIndex > 255 then begin Error(6); stringIndex := 1; end; {if} numString[stringIndex] := c2; NextChar; end; {while} end; {GetDigits} begin {DoNumber} isHex := false; {assume it's not hex} isReal := false; {assume it's an integer} isLong := false; {assume a short integer} unsigned := false; {assume signed numbers} stringIndex := 0; {no digits so far...} if scanWork then begin {set up the scanner} numIndex := 0; NextChar; end {if} else c2 := ch; if c2 = '.' then begin {handle the case of no leading digits} stringIndex := 1; numString[1] := '0'; end {if} else begin GetDigits; {read the leading digit stream} if c2 in ['x','X'] then {detect hex numbers} if stringIndex = 1 then if numString[1] = '0' then begin stringIndex := 2; numString[2] := 'X'; NextChar; isHex := true; GetDigits; goto 1; end; {if} end; if c2 = '.' then begin {handle a decimal} stringIndex := stringIndex+1; numString[stringIndex] := '.'; NextChar; isReal := true; if charKinds[ord(c2)] = digit then GetDigits else if stringIndex = 2 then begin numString[3] := '0'; stringIndex := 3; end; {else} end; {if} if c2 in ['e','E'] then begin {handle an exponent} stringIndex := stringIndex+1; numString[stringIndex] := 'e'; NextChar; isReal := true; if c2 in ['+','-'] then begin stringIndex := stringIndex+1; numString[stringIndex] := c2; NextChar; end; {if} if c2 in ['0'..'9'] then GetDigits else begin stringIndex := stringIndex+1; numString[stringIndex] := '0'; Error(101); end; {else} end; {if} 1: while c2 in ['l','u','L','U'] do {check for long or unsigned} if c2 in ['l','L'] then begin NextChar; if not isReal then isLong := true; end {if} else {if c2 in ['u','U'] then} begin NextChar; unsigned := true; if isReal then Error(91); end; {else} if c2 in ['f','F'] then begin {allow F designator on reals} if unsigned then Error(91); if not isReal then begin Error(100); isReal := true; end; {if} NextChar; end; {if} numString[0] := chr(stringIndex); {set the length of the string} if isReal then begin {convert a real constant} token.kind := doubleConst; token.class := doubleConstant; if stringIndex > 80 then begin Error(6); token.rval := 0.0; end {if} else token.rval := cnvsd(numString); end {if} else if numString[1] <> '0' then begin {convert a decimal integer} if (stringIndex > 5) or (not unsigned and (stringIndex = 5) and (numString > '32767')) or (unsigned and (stringIndex = 5) and (numString > '65535')) then isLong := true; if (stringIndex > 10) or ((stringIndex = 10) and (numString > '4294967295')) then begin numString := '0'; if flagOverflows then Error(6); end; {if} if isLong then begin token.class := longConstant; token.lval := Convertsl(numString); if unsigned then token.kind := ulongConst else begin token.kind := longConst; if token.lval < 0 then token.kind := ulongConst; end; {else} end {if} else begin if unsigned then token.kind := uintConst else token.kind := intConst; token.class := intConstant; token.lval := Convertsl(numString); end; {else} end {else if} else begin {hex & octal} token.lval := 0; if isHex then begin i := 3; while i <= length(numString) do begin if token.lval & $F0000000 <> 0 then begin i := maxint; if flagOverflows then Error(6); end {if} else begin if numString[i] > '9' then val := (ord(numString[i])-7) & $000F else val := ord(numString[i]) & $000F; token.lval := (token.lval << 4) | val; i := i+1; end; {else} end; {while} end {if} else begin i := 1; while i <= length(numString) do begin if token.lval & $E0000000 <> 0 then begin i := maxint; if flagOverflows then Error(6); end {if} else begin if numString[i] in ['8','9'] then Error(7); token.lval := (token.lval << 3) | (ord(numString[i]) & $0007); i := i+1; end; {else} end; {while} end; {else} if long(token.lval).msw <> 0 then isLong := true; if isLong then begin if unsigned then token.kind := ulongConst else token.kind := longConst; token.class := longConstant; end {if} else begin if (long(token.lval).lsw & $8000) <> 0 then unsigned := true; if unsigned then token.kind := uintConst else token.kind := intConst; token.class := intConstant; end; {else} end; {else} if saveNumber then begin sp := pointer(GMalloc(length(numString)+1)); CopyString(pointer(sp), @numString); token.numString := sp; end; {if} if scanWork then {make sure we read all characters} if ord(workString[0]) <> numIndex then Error(63); end; {DoNumber} procedure InitScanner {start, end: ptr}; { initialize the scanner } { } { start - pointer to the first character in the file } { end - points one byte past the last character in the file } var chi: minChar..maxChar; {loop variable} lch: char; {next command line character} cp: ptr; {character pointer} i: 0..hashSize; {loop variable} negative: boolean; {is a number nagative?} mp: macroRecordPtr; {for building the predefined macros} bp: ^macroRecordPtr; timeString: packed array[1..20] of char; {time from misc. tools} procedure NextCh; { Get the next character from the command line } begin {NextCh} lch := chr(cp^); cp := pointer(ord4(cp)+1); tokenColumn := tokenColumn+1; if tokenColumn > infoStringGS.theString.size then lch := chr(0); end; {NextCh} function GetWord: stringPtr; { Read a word from the command line } var i: integer; {string index} sp: stringPtr; {string pointer} begin {GetWord} i := 0; while not (lch in [' ', chr(0), chr(9), '=']) do begin i := i+1; workString[i] := lch; NextCh; end; {while} workString[0] := chr(i); sp := pointer(malloc(length(workString)+1)); CopyString(pointer(sp), @workString); GetWord := sp; end; {GetWord} function EscapeCh: integer; { Find and return the next character in a string or char } { constant. Handle escape sequences if they are found. } { (The character is returned as an ordinal value.) } { } { Globals: } { lch - first character in sequence; set to first char } { after sequence } label 1; var dig: 0..15; {value of a hex digit} skipChar: boolean; {get next char when done?} val: 0..4095; {hex escape code value (scaled to 0..255)} begin {EscapeCh} 1: skipChar := true; if lch = '\' then begin NextCh; if lch in ['0'..'7','a','b','t','n','v','f','p','r','x'] then case lch of '0','1','2','3','4','5','6','7': begin val := 0; while lch in ['0'..'7'] do begin val := (val << 3) | (ord(lch) & 7); NextCh; end; {while} EscapeCh := val & $FF; skipChar := false; end; 'a': EscapeCh := 7; 'b': EscapeCh := 8; 't': EscapeCh := 9; 'n': EscapeCh := 10; 'v': EscapeCh := 11; 'f': EscapeCh := 12; 'p': begin EscapeCh := ord('p'); ispstring := true; end; 'r': EscapeCh := 13; 'x': begin val := 0; NextCh; while lch in ['0'..'9','a'..'f','A'..'F'] do begin if lch in ['0'..'9'] then dig := ord(lch) & $0F else begin lch := chr(ord(lch)&$5F); dig := ord(lch)-ord('A')+10; end; {else} val := (val << 4) | dig; NextCh; end; {while} skipChar := false; EscapeCh := val & $FF; end; otherwise: Error(57); end {case} else EscapeCh := ord(lch); end {if} else EscapeCh := ord(lch); if skipChar then NextCh; end; {EscapeCh} procedure GetString; { read a string token from the command line } var i: integer; {string length} setLength: boolean; {is the current string a p-string?} sPtr: longstringPtr; {work string pointer} begin {GetString} token.kind := stringconst; {set up the token} token.class := stringConstant; i := 0; {set up for the string scan} ispstring := false; setLength := false; new(sPtr); NextCh; {skip the opening "} {read the characters} while not (charKinds[ord(lch)] in [ch_string,ch_eol,ch_eof]) do begin i := i+1; if i = longstringlen then begin i := 1001; Error(90); end; {if} sPtr^.str[i] := chr(EscapeCh); if (i = 1) and ispstring then setLength := true; end; {while} if lch = '"' then {process the end of the string} NextCh else Error(3); if setLength then {check for a p-string} sPtr^.str[1] := chr(i-1); token.ispstring := setLength; sPtr^.length := i; {set the string length} token.sval := pointer(Malloc(i+3)); {put the string in the string pool} CopyLongString(token.sval, pointer(sPtr)); dispose(sPtr); token.sval^.str[i+1] := chr(0); {add null in case the string is extended} end; {GetString} begin {InitScanner} printMacroExpansions := false; {don't print the token list} skipIllegalTokens := false; {flag illegal tokens in skipped code} slashSlashComments := true; {allow // comments} foundFunction := false; {no functions found so far} fileList := nil; {no included files} gettingFileName := false; {not in GetFileName} ifList := nil; {no conditional comp. records} skipping := false; {not skipping tokens} flagOverflows := true; {flag overflow errors?} new(macros); {no preprocessor macros so far} for i := 0 to hashSize do macros^[i] := nil; pathList := nil; {no additional search paths} charKinds[ord('#')] := illegal; {don't allow # as a token} tokenList := nil; {nothing in putback buffer} saveNumber := false; {don't save numbers} expandMacros := true; {enable macro expansion} reportEOL := false; {report eolsy as a token?} lineNumber := 1; {start the line counter} chPtr := start; {set the start, end pointers} eofPtr := endPtr; firstPtr := start; {first char in line} numErr := 0; {no errors so far} numErrors := 0; includeCount := 0; {no pending calls to EndInclude} lint := 0; {turn off lint checks} ch := chr(RETURN); {set the initial character} needWriteLine := false; {no lines are pending} switchLanguages := false; {not switching languages} lastWasReturn := false; {last char was not return} doingstring := false; {not doing a string} unix_1 := false; {int is 16 bits} new(mp); {__LINE__} mp^.name := @'__LINE__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 1; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; new(mp); {__FILE__} mp^.name := @'__FILE__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 2; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; new(mp); {__DATE__} mp^.name := @'__DATE__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 3; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; new(mp); {__TIME__} mp^.name := @'__TIME__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 4; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; new(mp); {__STDC__} mp^.name := @'__STDC__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 5; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; new(mp); {__ORCAC__} mp^.name := @'__ORCAC__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 5; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; new(mp); {__VERSION__} mp^.name := @'__VERSION__'; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := true; mp^.algorithm := 6; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; SetDateTime; {set up the macro date/time strings} {set up the version string} versionStrL := pointer(GMalloc(3 + length(versionStr))); versionStrL^.length := length(versionStr); versionStrL^.str := versionStr; {Scan the command line options} cp := @infoStringGS.theString.theString; tokenLine := 0; tokenColumn := 0; NextCh; repeat while lch in [' ', chr(9)] do {skip leading blanks} NextCh; if lch = '-' then begin {see if we have found one} NextCh; if lch in ['d','D'] then begin NextCh; {yes -> get the name} new(mp); {form the macro table entry} mp^.name := GetWord; mp^.parameters := -1; mp^.tokens := nil; mp^.readOnly := false; bp := pointer(ord4(macros) + hash(mp^.name)); mp^.next := bp^; bp^ := mp; if lch = '=' then begin NextCh; {record the value} token.numString := nil; if lch in ['a'..'z', 'A'..'Z', '_'] then begin token.kind := ident; token.class := identifier; token.name := GetWord; token.symbolPtr := nil; end {if} else if lch in ['+','-'] then begin negative := lch = '-'; NextCh; if lch in ['.','0'..'9'] then begin token.name := GetWord; DoNumber(true); if negative then case token.class of intConstant : token.ival := -token.ival; longConstant : token.lval := -token.lval; doubleConstant: token.rval := -token.rval; otherwise: ; end; {case} end {if} else begin token.kind := intconst; token.numString := nil; token.class := intConstant; token.ival := 0; end; {else} end {else if} else if lch in ['.','0'..'9'] then begin token.name := GetWord; DoNumber(true); end {else if} else if lch = '"' then GetString else Error(108); end {if} else begin token.kind := intconst; {create the default value} token.numString := nil; token.class := intConstant; token.ival := 1; end; {else} new(mp^.tokens); {add the value to the definition} with mp^.tokens^ do begin next := nil; tokenString := nil; expandEnabled := true; tokenStart := nil; tokenEnd := nil; end; {with} mp^.tokens^.token := token; end {if} else if lch in ['i','I'] then begin NextCh; {gat the pathname} if lch = '"' then begin GetString; LongToPString(workString, token.sval); AddPath(workString); end {if} else Error(103); end {if} else {not -p, -i: flag the error} Error(108); end {if} else if lch <> chr(0) then begin Error(108); {unknown option: flag the error} lch := chr(0); end; {else} until lch = chr(0); {if more characters, loop} end; {InitScanner} procedure CheckIdentifier; { See if an identifier is a reserved word, macro or typedef } label 1; var bPtr: ^macroRecordPtr; {pointer to hash bucket} mPtr: macroRecordPtr; {for checking list of macros} rword: tokenEnum; {loop variable} sp: stringPtr; {for saving identifier names} lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} begin {CheckIdentifier} if expandMacros then {handle macro expansions} if not skipping then begin mPtr := FindMacro(@workstring); if mPtr <> nil then begin Expand(mPtr); lPrintMacroExpansions := printMacroExpansions; printMacroExpansions := false; NextToken; printMacroExpansions := lPrintMacroExpansions; goto 1; end; end; {if} {see if it's a reserved word} if workString[1] in ['a'..'g','i','l','p','r'..'w'] then for rword := wordHash[ord(workString[1])-ord('a')] to pred(wordHash[ord(succ(workString[1]))-ord('a')]) do if reservedWords[rword] = workString then begin token.kind := rword; token.class := reservedWord; goto 1; end; {if} token.symbolPtr := nil; {see if it's a typedef name} if FindSymbol(token,allSpaces,false,false) <> nil then begin if token.symbolPtr^.class = typedefsy then token.kind := typedef; token.name := token.symbolPtr^.name; {use the old name} end {if} else begin {record the name} sp := pointer(Malloc(length(workString)+1)); CopyString(pointer(sp), @workString); token.name := sp; end; {else} 1: end; {CheckIdentifier} procedure NextToken; { Read the next token from the file. } label 1,2,3,4; type three = (s100,s1000,s4000); {these declarations are used for a} gstringPtr = ^gstringRecord; { variable length string record } gstringRecord = record case three of s100: (len1: integer; str1: packed array[1..100] of char; ); s1000: (len2: integer; str2: packed array[1..1000] of char; ); s4000: (len3: integer; str3: packed array[1..longstringlen] of char; ); end; var done: boolean; {loop termination} expandEnabled: boolean; {can a token be expanded?} i: 0..maxint; {loop/index counter} inhibit: boolean; {inhibit macro expansion?} lPrintMacroExpansions: boolean; {local copy of printMacroExpansions} mPtr: macroRecordPtr; {for checking list of macros} setLength: boolean; {is the current string a p-string?} tPtr: tokenListRecordPtr; {for removing tokens from putback buffer} tToken: tokenType; {for merging tokens} sPtr,tsPtr: gstringPtr; {for forming string constants} function EscapeCh: integer; { Find and return the next character in a string or char } { constant. Handle escape sequences if they are found. } { (The character is returned as an ordinal value.) } { } { Globals: } { ch - first character in sequence; set to first char } { after sequence } label 1; var dig: 0..15; {value of a hex digit} skipChar: boolean; {get next char when done?} val: 0..4095; {hex escape code value (scaled to 0..255)} begin {EscapeCh} 1: skipChar := true; if ch = '\' then begin NextCh; if ch in ['0'..'7','a','b','t','n','v','f','p','r','x'] then case ch of '0','1','2','3','4','5','6','7': begin val := 0; while ch in ['0'..'7'] do begin val := (val << 3) | (ord(ch) & 7); NextCh; end; {while} EscapeCh := val & $FF; skipChar := false; end; 'a': EscapeCh := 7; 'b': EscapeCh := 8; 't': EscapeCh := 9; 'n': EscapeCh := 10; 'v': EscapeCh := 11; 'f': EscapeCh := 12; 'p': begin EscapeCh := ord('p'); ispstring := true; end; 'r': EscapeCh := 13; 'x': begin val := 0; NextCh; while ch in ['0'..'9','a'..'f','A'..'F'] do begin if ch in ['0'..'9'] then dig := ord(ch) & $0F else begin ch := chr(ord(ch)&$5F); dig := ord(ch)-ord('A')+10; end; {else} val := (val << 4) | dig; NextCh; end; {while} skipChar := false; EscapeCh := val & $FF; end; otherwise: Error(57); end {case} else EscapeCh := ord(ch); end {if} else EscapeCh := ord(ch); if skipChar then NextCh; end; {EscapeCh} begin {NextToken} if ifList = nil then {do pending EndInclude calls} while includeCount <> 0 do begin EndInclude(includeChPtr); includeCount := includeCount - 1; end; {while} includeChPtr := chPtr; 3: token.numstring := nil; {wipe out old numstrings} if tokenList <> nil then begin {get a token put back by a macro} tPtr := tokenList; tokenList := tPtr^.next; expandEnabled := tPtr^.expandEnabled; token := tPtr^.token; tokenStart := tPtr^.tokenStart; tokenEnd := tPtr^.tokenEnd; dispose(tPtr); if token.kind = typedef then {allow for typedefs in a macro} token.kind := ident; if token.kind = ident then if FindSymbol(token,allSpaces,false,false) <> nil then if token.symbolPtr^.class = typedefsy then token.kind := typedef; 4: while (token.kind = stringconst) and (tokenList <> nil) and (tokenList^.token.kind = stringconst) do begin Merge(token, tokenList^.token); tPtr := tokenList; tokenList := tPtr^.next; dispose(tPtr); end; {while} if expandMacros and expandEnabled and (not skipping) then if token.kind = ident then begin {handle macro expansions} inhibit := false; if tokenList <> nil then if tokenList^.token.kind = poundpoundop then inhibit := true; if not inhibit then begin mPtr := FindMacro(token.name); if mPtr <> nil then begin Expand(mPtr); goto 3; end; {if} end; {if} end; {if} if tokenList <> nil then if tokenList^.token.kind = poundpoundop then begin tPtr := tokenList; tokenList := tPtr^.next; dispose(tPtr); if tokenList <> nil then begin tPtr := tokenList; tToken := token; Merge(tToken, tPtr^.token); tokenList := tPtr^.next; token := tToken; dispose(tPtr); goto 4; end; {if} end; {if} goto 2; end; {if} {skip white space} while charKinds[ord(ch)] in [illegal,ch_white,ch_eol] do begin if charKinds[ord(ch)] = illegal then begin if (ch = '#') and (lastWasReturn or (token.kind = eolsy)) then PreProcess {call the preprocessor} else begin tokenLine := lineNumber; {record a # token} tokenColumn := ord(ord4(chPtr)-ord4(firstPtr)); tokenStart := pointer(ord4(chPtr)-1); tokenEnd := chPtr; if (not skipping) or (not (skipIllegalTokens or (ch = '#'))) then Error(1); NextCh; end; {else} end {if} else if (charKinds[ord(ch)] = ch_eol) and reportEOL then begin token.class := reservedSymbol; {record an eol token} token.kind := eolsy; tokenLine := lineNumber; tokenColumn := ord(ord4(chPtr)-ord4(firstPtr)); tokenStart := pointer(ord4(chPtr)-1); tokenEnd := chPtr; NextCh; goto 2; end {if} else begin {skip white space} if printMacroExpansions then if charKinds[ord(ch)] = ch_eol then writeln else write(ch); NextCh; end; end; {while} tokenLine := lineNumber; {record the position of the token} tokenColumn := ord(ord4(chPtr)-ord4(firstPtr)); tokenStart := pointer(ord4(chPtr)-1); token.class := reservedSymbol; {default to the most common class} case charKinds[ord(ch)] of ch_special : begin token.kind := charSym[ord(ch)]; NextCh; end; ch_eof: {end of file} token.kind := eofsy; ch_pound : begin {tokens that start with '#'} NextCh; if ch = '#' then begin token.kind := poundpoundop; NextCh; end else token.kind := poundch; end; ch_dash : begin {tokens that start with '-'} NextCh; if ch = '>' then begin token.kind := minusgtop; NextCh; end else if ch = '-' then begin token.kind := minusminusop; NextCh; end else if ch = '=' then begin token.kind := minuseqop; NextCh; end else token.kind := minusch; end; ch_plus : begin {tokens that start with '+'} NextCh; if ch = '+' then begin token.kind := plusplusop; NextCh; end else if ch = '=' then begin token.kind := pluseqop; NextCh; end else token.kind := plusch; end; ch_lt : begin {tokens that start with '<'} NextCh; if ch = '<' then begin NextCh; if ch = '=' then begin token.kind := ltlteqop; NextCh; end else token.kind := ltltop; end else if ch = '=' then begin token.kind := lteqop; NextCh; end else token.kind := ltch; end; ch_gt : begin {tokens that start with '>'} NextCh; if ch = '>' then begin NextCh; if ch = '=' then begin token.kind := gtgteqop; NextCh; end else token.kind := gtgtop; end else if ch = '=' then begin token.kind := gteqop; NextCh; end else token.kind := gtch; end; ch_eq : begin {tokens that start with '='} NextCh; if ch = '=' then begin token.kind := eqeqop; NextCh; end else token.kind := eqch; end; ch_exc : begin {tokens that start with '!'} NextCh; if ch = '=' then begin token.kind := exceqop; NextCh; end else token.kind := excch; end; ch_and : begin {tokens that start with '&'} NextCh; if ch = '&' then begin token.kind := andandop; NextCh; end else if ch = '=' then begin token.kind := andeqop; NextCh; end else token.kind := andch; end; ch_bar : begin {tokens that start with '|'} NextCh; if ch = '|' then begin token.kind := barbarop; NextCh; end else if ch = '=' then begin token.kind := bareqop; NextCh; end else token.kind := barch; end; ch_percent: begin {tokens that start with '%'} NextCh; if ch = '=' then begin token.kind := percenteqop; NextCh; end else token.kind := percentch; end; ch_carot : begin {tokens that start with '^'} NextCh; if ch = '=' then begin token.kind := caroteqop; NextCh; end else token.kind := carotch; end; ch_asterisk: begin {tokens that start with '*'} NextCh; if ch = '=' then begin token.kind := asteriskeqop; NextCh; end else token.kind := asteriskch; end; ch_slash : begin {tokens that start with '/'} NextCh; if ch = '=' then begin token.kind := slasheqop; NextCh; end else token.kind := slashch; end; ch_dot : begin {tokens that start with '.'} if charKinds[chPtr^] = digit then DoNumber(false) else begin NextCh; token.kind := dotch; end; {else} end; ch_char : begin {character constants} NextCh; token.kind := intconst; token.class := intConstant; if ch = '''' then begin if (not skipping) or (not skipIllegalTokens) then Error(2); token.ival := ord(' '); end {if} else token.ival := EscapeCh; if ch = '''' then NextCh else if (not skipping) or (not skipIllegalTokens) then Error(2); end; ch_string: begin {string constants} doingstring := true; {change character scanning} token.kind := stringconst; {set up the token} token.class := stringConstant; i := 0; {set up for the string scan} ispstring := false; setLength := false; new(sPtr,s100); NextCh; {skip the opening "} {read the characters} while not (charKinds[ord(ch)] in [ch_string,ch_eol,ch_eof]) do begin i := i+1; if i = 101 then begin sPtr^.len1 := 100; new(tsPtr,s1000); CopyLongString(pointer(tsPtr), pointer(sPtr)); dispose(sPtr); sPtr := tsPtr; end {if} else if i = 1001 then begin sPtr^.len2 := 1000; new(tsPtr,s4000); CopyLongString(pointer(tsPtr), pointer(sPtr)); dispose(sPtr); sPtr := tsPtr; end {else if} else if i = longstringlen then begin i := 1001; Error(90); end; {else if} sPtr^.str1[i] := chr(EscapeCh); if (i = 1) and ispstring then setLength := true; end; {while} doingstring := false; {process the end of the string} if ch = '"' then NextCh else Error(3); if setLength then {check for a p-string} sPtr^.str1[1] := chr(i-1); token.ispstring := setLength; sPtr^.len1 := i; {set the string length} token.sval := pointer(Malloc(i+3)); {put the string in the string pool} CopyLongString(token.sval, pointer(sPtr)); dispose(sPtr); doingstring := false; token.sval^.str[i+1] := chr(0); {add null in case the string is extended} end; letter: begin {reserved words and identifiers} token.kind := ident; token.class := identifier; token.name := @workString; i := 0; while charKinds[ord(ch)] in [letter,digit] do begin i := i+1; workString[i] := ch; NextCh; end; {while} workString[0] := chr(i); CheckIdentifier; end; digit : {numeric constants} DoNumber(false); otherwise: Error(57); end; {case} tokenEnd := pointer(ord4(chPtr)-1); {record the end of the token} 2: if skipping then {conditional compilation branch} if not (token.kind in [eofsy,eolsy]) then goto 3; if token.kind = stringconst then {handle adjacent strings} repeat if reportEOL then begin while charKinds[ord(ch)] = ch_white do NextCh; if charKinds[ord(ch)] = ch_eol then goto 1; end; {if} tToken := token; lPrintMacroExpansions := printMacroExpansions; printMacroExpansions := false; NextToken; printMacroExpansions := lPrintMacroExpansions; if token.kind = stringconst then begin Merge(tToken, token); done := false; end {if} else begin PutBackToken(token, true); done := true; end; {else} token := tToken; until done; 1: if printMacroExpansions then {print the token stream} PrintToken(token); end; {NextToken} procedure TermScanner; { Shut down the scanner. } begin {TermScanner} if ifList <> nil then Error(21); if numErr <> 0 then begin {write any pending errors} firstPtr := chPtr; WriteLine; end; {if} end; {TermScanner} end. {$append 'scanner.asm'} \ No newline at end of file diff --git a/Symbol.Print b/Symbol.Print new file mode 100755 index 0000000..fff86ff --- /dev/null +++ b/Symbol.Print @@ -0,0 +1 @@ +procedure PrintOneSymbol {ip: identPtr}; { Print a symbol } { } { Parameters: } { ip - identifier to print } procedure PrintClass (class: tokenEnum); { Print the class of a symbol } { } { Parameters: } { class - class of the symbol } begin {PrintClass} case class of autosy: write('auto'); externsy: write('extern'); ident: write('ident'); otherwise: write(ord(class):1); end; {case} end; {PrintClass} procedure PrintType (tp: typePtr); { Print a type } { } { Parameters: } { tp - type pointer } begin {PrintType} with tp^ do begin write(' ', size:1, ' byte '); if isConstant then write('constant '); case kind of scalarType : writeln('scalar'); arrayType : begin writeln(elements: 1, ' element array of'); PrintType(aType); end; pointerType : begin writeln(' pointer to'); PrintType(pType); end; functionType: begin writeln(' function returning'); PrintType(fType); end; enumConst : writeln('enumeration (', eval: 1, ')'); enumType : writeln('enum type'); definedType : begin writeln('defined type of'); PrintType(dType); end; structType : writeln('struct: ', ord4(tp):1); unionType : writeln('union'); end; {case} end; {with} end; {PrintType} begin {PrintOneSymbol} with ip^ do begin writeln; {start with a blank line} write(name^, {write id info} ': isForwardDeclared = ', isForwardDeclared, '; class = '); PrintClass(class); writeln; PrintType(iType); {print type info} end; {with} end; {PrintOneSymbol} procedure PrintTable {sym: symbolTablePtr}; { print a symbol table } { } { parameters: } { sym - symbol table to print } var i: integer; {loop variable} ip: identPtr; {current symbol} begin {PrintTable} if sym <> nil then begin writeln; {write header} writeln('Symbols:'); writeln('========'); for i := 0 to hashSize do begin {loop over all hash buckets} ip := sym^.buckets[i]; {trace through all symbols in this bucket} while ip <> nil do begin PrintOneSymbol(ip); {print a symbol} ip := ip^.next; {next symbol} end; {while} end; {for} end; {if} end; {PrintTable} \ No newline at end of file diff --git a/Symbol.asm b/Symbol.asm new file mode 100755 index 0000000..abfc655 --- /dev/null +++ b/Symbol.asm @@ -0,0 +1 @@ + mcopy symbol.macros **************************************************************** * * ClearTable - set the symbol table to zeros * * Inputs: * table - symbol table address * **************************************************************** * ClearTable private tableSize equ 7026 sizeof(symbolTable) subroutine (4:table),0 ldy #tableSize-2 lda #0 lb1 sta [table],Y dey dey bpl lb1 return end \ No newline at end of file diff --git a/Symbol.macros b/Symbol.macros new file mode 100755 index 0000000..33a7632 --- /dev/null +++ b/Symbol.macros @@ -0,0 +1 @@ + MACRO &lab subroutine &parms,&work &lab anop aif c:&work,.a lclc &work &work setc 0 .a gbla &totallen gbla &worklen &worklen seta &work &totallen seta 0 aif c:&parms=0,.e lclc &len lclc &p lcla &i &i seta c:&parms .b &p setc &parms(&i) &len amid &p,2,1 aif "&len"=":",.c &len amid &p,1,2 &p amid &p,4,l:&p-3 ago .d .c &len amid &p,1,1 &p amid &p,3,l:&p-2 .d &p equ &totallen+3+&work &totallen seta &totallen+&len &i seta &i-1 aif &i,^b .e tsc sec sbc #&work tcs inc a phd tcd mend MACRO &lab return &r &lab anop lclc &len aif c:&r,.a lclc &r &r setc 0 &len setc 0 ago .h .a &len amid &r,2,1 aif "&len"=":",.b &len amid &r,1,2 &r amid &r,4,l:&r-3 ago .c .b &len amid &r,1,1 &r amid &r,3,l:&r-2 .c aif &len<>2,.d ldy &r ago .h .d aif &len<>4,.e ldx &r+2 ldy &r ago .h .e aif &len<>10,.g aif &totallen=0,.f lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .f pld tsc clc adc #&worklen+&totallen tcs phb plx ply lda &r+8 pha lda &r+6 pha lda &r+4 pha lda &r+2 pha lda &r pha phy phx plb rtl mexit .g mnote 'Not a valid return length',16 mexit .h aif &totallen=0,.i lda &worklen+1 sta &worklen+&totallen+1 lda &worklen sta &worklen+&totallen .i pld tsc clc adc #&worklen+&totallen tcs aif &len=0,.j tya .j rtl mend \ No newline at end of file diff --git a/Symbol.pas b/Symbol.pas new file mode 100755 index 0000000..781d17a --- /dev/null +++ b/Symbol.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Symbol Table } { } { Handle the symbol table. } { } { External Subroutines: } { } { CheckStaticFunctions - check for undefined functions } { CompTypes - Determine if the two types are compatible } { DoGlobals - declare the ~globals and ~arrays segments } { FindSymbol - locate a symbol in the symbol table } { GenParameters - Generate labels and space for the parameters } { GenSymbols - generate a symbol table for the debugger } { InitSymbol - initialize the symbol table handler } { NewSymbol - insert a new symbol in the symbol table } { PopTable - Pop a symbol table (remove definitions local to a } { block) } { PushTable - Create a new symbol table, pushing the old one } { ResolveForwardReference - resolve a forward reference } { } { External Variables: } { } { noDeclarations - have we declared anything at this level? } { table - current symbol table } { } { bytePtr - pointer to the base type for bytes } { uBytePtr - pointer to the base type for unsigned bytes } { wordPtr - pointer to the base type for words } { uWordPtr - pointer to the base type for unsigned words } { longPtr - pointer to the base type for long words } { uLongPtr - pointer to the base type for unsigned long words } { realPtr - pointer to the base type for reals } { doublePtr - pointer to the base type for double precision } { reals } { compPtr - pointer to the base type for comp reals } { extendedPtr - pointer to the base type for extended reals } { voidPtr - pointer to the base type for void } { voidPtrPtr - typeless pointer, for some type casting } { stringTypePtr - pointer to the base type for string } { constants } { defaultStruc - default for structures with errors } { } {---------------------------------------------------------------} unit Symbol; {$LibPrefix '0/obj/'} interface uses CCommon, CGI, MM, Scanner; {$segment 'cc'} {---------------------------------------------------------------} type symbolTablePtr = ^symbolTable; symbolTable = record {a symbol table} {NOTE: the array of buckets must come first in the record!} buckets: array[0..hashSize2] of identPtr; {hash buckets} next: symbolTablePtr; {next symbol table} staticNum: packed array[1..6] of char; {staticNum at start of table} end; var noDeclarations: boolean; {have we declared anything at this level?} table: symbolTablePtr; {current symbol table} globalTable: symbolTablePtr; {global symbol table} bytePtr,uBytePtr,wordPtr,uWordPtr, {base types} longPtr,uLongPtr,realPtr,doublePtr,compPtr,extendedPtr, stringTypePtr,voidPtr,voidPtrPtr,defaultStruct: typePtr; {---------------------------------------------------------------} procedure CheckStaticFunctions; { check for undefined functions } function CompTypes (t1, t2: typePtr): boolean; { Determine if the two types are compatible } procedure DoGlobals; { declare the ~globals and ~arrays segments } function FindSymbol (var tk: tokenType; class: spaceType; oneLevel: boolean; staticAllowed: boolean): identPtr; { locate a symbol in the symbol table } { } { parameters: } { tk - token record for the identifier to find } { class - the kind of variable space to search } { oneLevel - search one level only? (used to check for } { duplicate symbols) } { staticAllowed - can we check for static variables? } { } { returns: } { A pointer to the symbol table entry is returned. If } { there is no entry, nil is returned. } procedure GenParameters (pp: parameterPtr); { Generate labels and space for the parameters } { } { parameters: } { pp - pointer to first parameter } procedure GenSymbols (sym: symbolTablePtr; doGlobals: boolean); { generate a symbol table for the debugger } { } { parameters: } { sym - symbol table to generate } { doGlobals - include global symbols in the table } { } { outputs: } { symLength - length of debug symbol table } procedure InitSymbol; { Initialize the symbol table module } function LabelToDisp (lab: integer): integer; extern; { convert a local label number to a stack frame displacement } { } { parameters: } { lab - label number } function NewSymbol (name: stringPtr; itype: typePtr; class: tokenEnum; space: spaceType; state: stateKind): identPtr; { insert a new symbol in the symbol table } { } { parameters: } { name - pointer to the symbol name } { itype - pointer to the symbol type } { class - storage class } { space - the kind of variable space to put the } { identifier in } { state - variable declaration state } { } { returns: pointer to the inserted symbol } procedure PopTable; { Pop a symbol table (remove definitions local to a block) } {procedure PrintOneSymbol (ip: identPtr); {debug} { Print a symbol } { } { Parameters: } { ip - identifier to print } {procedure PrintTable (sym: symbolTablePtr); {debug} { print a symbol table } { } { parameters: } { sym - symbol table to print } procedure PushTable; { Create a new symbol table, pushing the old one } procedure ResolveForwardReference (iPtr: identPtr); { resolve a forward reference } { } { parameters: } { iPtr - ptr to the forward declared identifier } {---------------------------------------------------------------} implementation var staticNum, {static variable number} firstStaticNum: packed array[1..6] of char; {staticNum at start of function} {- Imported from expression.pas --------------------------------} procedure GenerateCode (tree: tokenPtr); extern; { generate code from a fully formed expression tree } { } { parameters: } { tree - top of the expression tree to generate code from } { } { variables: } { expressionType - result type of the expression } function UsualUnaryConversions: baseTypeEnum; extern; { performs the usual unary conversions } { } { inputs: } { expressionType - type of the operand } { } { result: } { The base type of the operation to perform is returned. } { Any conversion code necessary has been generated. } { } { outputs: } { expressionType - set to result type } {---------------------------------------------------------------} procedure CnOut (i: integer); extern; { write a byte to the constant buffer } { } { parameters: } { i - byte to write } procedure CnOut2 (i: integer); extern; { write a word to the constant buffer } { } { parameters: } { i - word to write } procedure Out (b: integer); extern; { write a byte to the output file } { } { parameters: } { b - byte to write } procedure Out2 (w: integer); extern; { write a word to the output file } { } { parameters: } { w - word to write } procedure RefName (lab: stringPtr; disp, len, shift: integer); extern; { handle a reference to a named label } { } { parameters: } { lab - label name } { disp - displacement past the label } { len - number of bytes in the reference } { shift - shift factor } procedure LabelSearch (lab: integer; len, shift, disp: integer); extern; { resolve a label reference } { } { parameters: } { lab - label number } { len - # bytes for the generated code } { shift - shift factor } { disp - disp past the label } { } { Note 1: maxlabel is reserved for use as the start of the } { string space } { Note 2: negative length indicates relative branch } { Note 3: zero length indicates 2 byte addr -1 } procedure Purge; extern; { write any constant bytes to the output buffer } {---------------------------------------------------------------} procedure ClearTable (table: symbolTable); extern; { clear the symbol table to all zeros } {---------------------------------------------------------------} procedure CheckStaticFunctions; { check for undefined functions } var i: 0..hashSize; {loop variable} sp: identPtr; {pointer to a symbol table entry} msg: stringPtr; {error message ptr} begin {CheckStaticFunctions} for i := 0 to hashSize do begin sp := globalTable^.buckets[i]; while sp <> nil do begin if sp^.storage = private then if sp^.itype^.kind = functionType then if sp^.state <> defined then begin numErrors := numErrors+1; new(msg); msg^ := concat('The static function ', sp^.name^, ' was not defined.'); writeln('*** ', msg^); if terminalErrors then begin if enterEditor then ExitToEditor(msg, ord4(firstPtr)-ord4(bofPtr)) else TermError(0); end; {if} liDCBGS.merrf := 16; end; {if} sp := sp^.next; end; {while} end; {for} end; {CheckStaticFunctions} function CompTypes {t1, t2: typePtr): boolean}; { Determine if the two types are compatible } label 1; var el1,el2: longint; {array sizes} kind1,kind2: typeKind; {temp variables (for speed)} p1, p2: parameterPtr; {for tracing parameter lists} pt1,pt2: typePtr; {pointer types} function IsVoid (tp: typePtr): boolean; { Check to see if a type is void } { } { Parameters: } { tp - type to check } { } { Returns: True if the type is void, else false } begin {IsVoid} IsVoid := false; if tp = voidPtr then IsVoid := true else if tp^.kind = scalarType then if tp^.baseType = cgVoid then IsVoid := true; end; {IsVoid} begin {CompTypes} CompTypes := false; {assume the types are not compatible} kind1 := t1^.kind; {get these for efficiency} kind2 := t2^.kind; if kind2 = definedType then {scan past type definitions} CompTypes := CompTypes(t1, t2^.dType) else if kind1 = definedType then CompTypes := CompTypes(t1^.dType, t2) else case kind1 of scalarType: if kind2 = scalarType then CompTypes := t1^.baseType = t2^.baseType else if kind2 = enumType then CompTypes := t1^.baseType = cgWord; arrayType: if kind2 = arrayType then begin el1 := t1^.elements; el2 := t2^.elements; if el1 = 0 then el1 := el2 else if el2 = 0 then el2 := el1; if el1 = el2 then CompTypes := CompTypes(t1^.atype, t2^.atype); end; {if} functionType: if kind2 = functionType then CompTypes := CompTypes(t1^.ftype,t2^.ftype) else if kind2 = pointerType then if t2^.ptype^.kind = functionType then CompTypes := CompTypes(t1, t2^.ptype); pointerType: begin if IsVoid(t1^.ptype) or IsVoid(t2^.ptype) then begin CompTypes := true; goto 1; end; {if} if kind2 = pointertype then CompTypes := CompTypes(t1^.ptype, t2^.ptype) else if kind2 = functionType then CompTypes := CompTypes(t1^.ptype, t2); end; enumType: if kind2 = scalarType then CompTypes := t2^.baseType = cgWord else if kind2 = enumType then CompTypes := true; structType,unionType: CompTypes := t1 = t2; otherwise: ; end; {case t1^.kind} 1: end; {CompTypes} procedure DoGlobals; { declare the ~globals and ~arrays segments } procedure GenArrays; { define global arrays } var didOne: boolean; {have we found an array yet?} i: 0..hashSize; {loop variable} ip: initializerPtr; {used to trace initializer lists} lval: longint; {for converting types} size: longint; {size of the array} sp: identPtr; {pointer to a symbol table entry} begin {GenArrays} didOne := false; for i := 0 to hashSize do begin sp := table^.buckets[i]; while sp <> nil do begin if sp^.storage in [global,private] then if sp^.itype^.kind in [arrayType,structType,unionType] then begin if not didOne then begin if smallMemoryModel then currentSegment := ' ' else currentSegment := '~ARRAYS '; Gen2Name(dc_str, $4000, 1, @'~ARRAYS'); didOne := true; end; {if} if sp^.state = initialized then begin Gen2Name(dc_glb, 0, ord(sp^.storage = private), sp^.name); ip := sp^.iPtr; while ip <> nil do begin case ip^.itype of cgByte,cgUByte,cgWord,cgUWord: begin lval := ip^.ival; Gen2t(dc_cns, long(lval).lsw, ip^.count, ip^.itype); end; cgLong,cgULong: GenL1(dc_cns, ip^.ival, ip^.count); cgReal,cgDouble,cgComp,cgExtended: GenR1t(dc_cns, ip^.rval, ip^.count, ip^.itype); cgString: GenS(dc_cns, ip^.sval); ccPointer: begin code^.optype := ccPointer; code^.r := ord(ip^.pPlus); code^.q := ip^.count; code^.pVal := ip^.pVal; if ip^.isName then begin code^.lab := ip^.pName; code^.pstr := nil; end {if} else code^.pstr := ip^.pstr; Gen0(dc_cns); end; otherwise: Error(57); end; {case} ip := ip^.next; end; {while} end {if} else begin size := sp^.itype^.size; Gen2Name(dc_glb, long(size).lsw & $7FFF, ord(sp^.storage = private), sp^.name); size := size & $FFFF8000; while size <> 0 do begin Gen1(dc_dst, 16384); size := size-16384; end; {while} end; {else} end; {if} sp := sp^.next; end; {while} end; {for} if didOne then Gen0(dc_enp); end; {GenArrays} procedure GenGlobals; { define non-array global variables } var i: 0..hashSize; {loop variable} ip: initializerPtr; {used to trace initializer lists} lval: longint; {for extracting lsw} sp: identPtr; {pointer to a symbol table entry} begin {GenGlobals} Gen2t(dc_cns, 0, 1, cgByte); for i := 0 to hashSize do begin sp := table^.buckets[i]; while sp <> nil do begin if sp^.storage in [global,private] then if sp^.itype^.kind in [scalarType,pointerType] then begin if sp^.state = initialized then begin Gen2Name(dc_glb, 0, ord(sp^.storage = private), sp^.name); ip := sp^.iPtr; case ip^.itype of cgByte,cgUByte,cgWord,cgUWord: begin lval := ip^.ival; Gen2t(dc_cns, long(lval).lsw, 1, ip^.itype); end; cgLong,cgULong: GenL1(dc_cns, ip^.ival, 1); cgReal,cgDouble,cgComp,cgExtended: GenR1t(dc_cns, ip^.rval, 1, ip^.itype); cgString: GenS(dc_cns, ip^.sval); ccPointer: begin code^.optype := ccPointer; code^.q := 1; code^.r := ord(ip^.pPlus); code^.pVal := ip^.pVal; if ip^.isName then begin code^.lab := ip^.pName; code^.pstr := nil; end {if} else code^.pstr := ip^.pstr; Gen0(dc_cns); end; otherwise: Error(57); end; {case} end {if} else Gen2Name(dc_glb, ord(sp^.itype^.size), ord(sp^.storage = private), sp^.name); end; sp := sp^.next; end; {while} end; {for} end; {GenGlobals} begin {DoGlobals} {print the global symbol table} {if printSymbols then {debug} { PrintTable(globalTable); {debug} {these segments are not dynamic!} segmentKind := 0; {declare the ~globals segment, which holds non-array data types} if smallMemoryModel then currentSegment := ' ' else currentSegment := '~GLOBALS '; Gen2Name(dc_str, $4000, 0, @'~GLOBALS'); GenGlobals; Gen0(dc_enp); {declare the ~arrays segment, which holds global arrays} GenArrays; end; {DoGlobals} function FindSymbol {var tk: tokenType; class: spaceType; oneLevel: boolean; staticAllowed: boolean): identPtr}; { locate a symbol in the symbol table } { } { parameters: } { tk - token record for the identifier to find } { class - the kind of variable space to search } { oneLevel - search one level only? (used to check for } { duplicate symbols) } { staticAllowed - can we check for static variables? } { } { returns: } { A pointer to the symbol table entry is returned. If } { there is no entry, nil is returned. } label 1; var doTagSpace: boolean; {do we still need to do the tags?} hashDisp: longint; {disp into the hash table} i: integer; {loop variable} iHandle: ^identPtr; {pointer to start of hash bucket} iPtr: identPtr; {pointer to the current symbol} match: boolean; {for comparing substrings} name: stringPtr; {name to search for} np: stringPtr; {for searching for static variables} sPtr: symbolTablePtr; {^ to current symbol table} begin {FindSymbol} {get ready to search} staticAllowed := staticAllowed and (staticNum <> '~0000'); name := tk.name; {use a local variable} hashDisp := Hash(name); {get the disp into the symbol table} sPtr := table; {initialize the address of the sym. tbl} FindSymbol := nil; {assume we won't find it} np := nil; {no string buffer, yet} {check for the variable} while sPtr <> nil do begin iHandle := pointer(hashDisp+ord4(sPtr)); if class = tagSpace then iHandle := pointer(ord4(iHandle) + (hashSize+1)*4); doTagSpace := class = allSpaces; iPtr := iHandle^; if iPtr = nil then if doTagSpace then begin iHandle := pointer(ord4(iHandle) + (hashSize+1)*4); iPtr := iHandle^; doTagSpace := false; end; {if} {scan the hash bucket for a global or auto variable} while iPtr <> nil do begin if iPtr^.name^ = name^ then begin FindSymbol := iPtr; if iPtr^.isForwardDeclared then ResolveForwardReference(iPtr); tk.symbolPtr := iPtr; goto 1; end; {if} iPtr := iPtr^.next; if iPtr = nil then if doTagSpace then begin iHandle := pointer(ord4(iHandle) + (hashSize+1)*4); iPtr := iHandle^; doTagSpace := false; end; {if} end; {while} {rescan for a static variable} if staticAllowed then begin if np = nil then begin {form the static name} if length(name^) < 251 then begin new(np); np^[0] := chr(5+length(name^)); for i := 1 to 5 do np^[i] := sPtr^.staticNum[i]; for i := 1 to length(name^) do np^[i+5] := name^[i]; end; {if} end {if} else for i := 2 to 5 do np^[i] := sPtr^.StaticNum[i]; {scan the hash bucket for the identifier} iHandle := pointer(hashDisp+ord4(globalTable)); if class = tagSpace then iHandle := pointer(ord4(iHandle) + (hashSize+1)*4); iPtr := iHandle^; while iPtr <> nil do begin if iPtr^.name^ = np^ then begin FindSymbol := iPtr; if iPtr^.isForwardDeclared then ResolveForwardReference(iPtr); tk.symbolPtr := iPtr; goto 1; end; {if} iPtr := iPtr^.next; end; {while} end; {if staticAllowed} if oneLevel then sPtr := nil else sPtr := sPtr^.next; end; {while} 1: if np <> nil then dispose(np); end; {FindSymbol} procedure GenParameters {pp: parameterPtr}; { Generate labels and space for the parameters } { } { parameters: } { pp - pointer to first parameter } var i: 0..hashSize; {loop variable} pln: integer; {label number} size: integer; {size of the parameter} sp: identPtr; {symbol pointer} tk: tokenType; {symbol name token} begin {GenParameters} if pp <> nil then begin {prototyped parameters} tk.kind := ident; tk.numString := nil; tk.class := identifier; while pp <> nil do begin pln := GetLocalLabel; tk.name := pp^.parameter^.name; tk.symbolPtr := nil; sp := FindSymbol(tk, variableSpace, true, false); if sp = nil then sp := pp^.parameter; if sp^.itype^.kind = arrayType then Gen3(dc_prm, pln, cgPointerSize, sp^.pdisp) else begin size := long(sp^.itype^.size).lsw; if (size = 1) and (sp^.itype^.kind = scalarType) then size := 2; Gen3(dc_prm, pln, size, sp^.pdisp); end; {else} sp^.pln := pln; pp := pp^.next; end; {while} end {if} else begin {K&R parameters} for i := 0 to hashSize do begin sp := table^.buckets[i]; while sp <> nil do begin if sp^.storage = parameter then begin sp^.pln := GetLocalLabel; if sp^.itype^.kind = arrayType then Gen3(dc_prm, sp^.lln, cgPointerSize, sp^.pdisp) else begin size := long(sp^.itype^.size).lsw; if (size = 1) and (sp^.itype^.kind = scalarType) then size := 2; Gen3(dc_prm, sp^.lln, size, sp^.pdisp); end; {else} end; {if} sp := sp^.next; end; {while} end; {for} end; {else} end; {GenParameters} procedure GenSymbols {sym: symbolTablePtr; doGlobals: boolean}; { generate a symbol table for the debugger } { } { parameters: } { sym - symbol table to generate } { doGlobals - include global symbols in the table } { } { outputs: } { symLength - length of debug symbol table } const noDisp = -1; {disp returned by GetTypeDisp if the type was not found} type tpPtr = ^tpRecord; {type list displacements} tpRecord = record next: tpPtr; tp: typePtr; disp: integer; end; var i: 0..hashSize; {loop/index variable} ip: identPtr; {used to trace identifier lists} tpList,tp2: tpPtr; {type displacement list} function GetTypeDisp (tp: typePtr): integer; { Look for an existing entry for this type } { } { Parameters: } { tp - type to look for } { } { Returns: Disp to a variable of the same type, or noDisp if } { there is no such entry. } { } { Notes: If the type is not in the type list, it is entered } { in the list by this call. } var tp1, tp2: tpPtr; {used to manipulate type list} begin {GetTypeDisp} tp1 := tpList; {look for the type} tp2 := nil; while tp1 <> nil do if tp1^.tp = tp then begin tp2 := tp1; tp1 := nil; end {if} else tp1 := tp1^.next; if tp2 <> nil then GetTypeDisp := tp2^.disp {return disp to entry} else begin GetTypeDisp := noDisp; {no entry} new(tp1); {create a new entry} tp1^.next := tpList; tpList := tp1; tp1^.tp := tp; tp1^.disp := symLength; end; {else} end; {GetTypeDisp} procedure GenSymbol (ip: identPtr; storage: storageType); { Generate a single symbol or struct field } { } { parameters: } { ip - identifier to generate } { storage - storage type; none for struct/union fields } var disp: integer; {disp to symbol of same type} procedure WriteAddress (ip: identPtr); { Write the address and DP flag } { } { parameters: } { ip - identifier } var size: longint; {used to break apart longints} begin {WriteAddress} if storage in [external,global,private] then begin RefName(ip^.name, 0, 4, 0); CnOut(1); end {if} else if storage = none then begin size := ip^.disp; CnOut2(long(size).lsw); CnOut2(long(size).msw); CnOut(ord(ip^.next <> nil)); end {else if} else begin CnOut2(LabelToDisp(ip^.lln)); CnOut2(0); CnOut(0); end; {else} end; {WriteAddress} procedure WriteName (ip: identPtr); { Write the name field for an identifier } { } { parameters: } { ip - identifier } var len: 0..maxint; {string length} j: 0..maxint; {loop/index variable} begin {WriteName} Purge; {generate the address of the variable } Out(235); Out(4); { name } LabelSearch(maxLabel, 4, 0, 0); if stringsize <> 0 then begin Out(129); Out2(stringsize); Out2(0); Out(1); end; {if} Out(0); len := length(ip^.name^); {place the name in the string buffer} if maxstring-stringsize >= len+1 then begin stringspace[stringsize+1] := chr(len); for j := 1 to len do stringspace[j+stringsize+1] := ip^.name^[j]; stringsize := stringsize+len+1; end {if} else Error(60); end; {WriteName} procedure WriteScalarType (tp: typePtr; modifiers, subscripts: integer); { Write a scalar type and subscipt field } { } { parameters: } { tp - type pointer } { modifiers - value to or with the type code } { subscripts - number of subscripts } var val: integer; {type value} begin {WriteScalarType} case tp^.baseType of cgByte: val := $40; cgUByte: val := $00; cgWord: val := $01; cgUWord: val := $41; cgLong: val := $02; cgULong: val := $42; cgReal: val := $03; cgDouble: val := $04; cgComp: val := $0A; cgExtended: val := $05; otherwise: val := $01; end; {case} CnOut(val | modifiers); {write the format byte} CnOut2(subscripts); {write the # of subscripts} end; {WriteScalarType} procedure WritePointerType (tp: typePtr; subscripts: integer); { write a pointer type field } { } { parameters: } { tp - pointer type } { subscripts - number of subscript fields } begin {WritePointerType} case tp^.ptype^.kind of scalarType: WriteScalarType(tp^.ptype, $80, subscripts); enumType, functionType: WriteScalarType(wordPtr, $80, subscripts); otherwise: begin CnOut(11); CnOut2(subscripts); end; end; {case} end; {WritePointerType} procedure ExpandPointerType (tp: typePtr); forward; procedure ExpandStructType (tp: typePtr); { write the type entries for a struct or union } { } { parameters: } { tp - struct/union type } var ip: identPtr; {used to trace the field list} begin {ExpandStructType} ip := tp^.fieldList; while ip <> nil do begin GenSymbol(ip, none); ip := ip^.next; end; {while} end; {ExpandStructType} procedure WriteArrays (tp: typePtr); { handle an array type } { } { parameters: } { tp - array type } var count: 0..maxint; {# of subscripts} size: longint; {for converting long numbers} tp2: typePtr; {used to trace array type list} begin {WriteArrays} count := 0; {count the subscripts} tp2 := tp; while tp2^.kind = arrayType do begin count := count+1; tp2 := tp2^.aType; end; {while} if tp2^.kind = scalarType then {write the type code} if tp2^.baseType in [cgByte,cgUByte] then begin count := count-1; CnOut(6); CnOut2(count); end {if} else WriteScalarType(tp2, 0, count) else if tp2^.kind = enumType then WriteScalarType(wordPtr, 0, count) else if tp2^.kind = pointerType then WritePointerType(tp2, count) else begin CnOut(12); CnOut2(count); end; {else if} while count <> 0 do begin {write the subscript entries} CnOut2(0); CnOut2(0); if tp^.elements = 0 then size := $00FFFFFF else size := tp^.elements-1; CnOut2(long(size).lsw); CnOut2(long(size).msw); size := tp^.aType^.size; CnOut2(long(size).lsw); CnOut2(long(size).msw); symLength := symLength+12; tp := tp^.aType; count := count-1; end; {while} if tp2^.kind = pointerType then {expand complex types} ExpandPointerType(tp2) else if tp2^.kind in [structtype,uniontype] then ExpandStructType(tp2); end; {WriteArrays} procedure ExpandPointerType {tp: typePtr}; { write the type entries for complex pointer types } { } { parameters: } { tp - pointer type } var disp: integer; {disp to symbol of same type} begin {ExpandPointerType} if tp^.ptype^.kind in [pointerType,arrayType,structType,unionType] then begin symLength := symLength+12; CnOut2(0); CnOut2(0); CnOut2(0); CnOut2(0); CnOut(0); case tp^.ptype^.kind of pointerType: begin WritePointerType(tp^.ptype, 0); ExpandPointerType(tp^.ptype); end; arrayType: WriteArrays(tp^.ptype); structType, unionType: begin disp := GetTypeDisp(tp^.ptype); if disp = noDisp then begin CnOut(12); CnOut2(0); ExpandStructType(tp^.ptype); end {if} else begin CnOut(13); CnOut2(disp); end; {else} end; end; {case} end; {if} end; {ExpandPointerType} begin {GenSymbol} if ip^.itype^.kind in [scalarType,arrayType,pointerType,enumType,structType,unionType] then begin WriteName(ip); {write the name field} WriteAddress(ip); {write the address field} case ip^.itype^.kind of scalarType: WriteScalarType(ip^.itype, 0, 0); enumType: WriteScalarType(wordPtr, 0, 0); pointerType: begin WritePointerType(ip^.itype, 0); ExpandPointerType(ip^.itype); end; arrayType: WriteArrays(ip^.itype); structType, unionType: begin disp := GetTypeDisp(ip^.itype); if disp = noDisp then begin CnOut(12); CnOut2(0); ExpandStructType(ip^.itype); end {if} else begin CnOut(13); CnOut2(disp); end; {else} end; end; {case} symLength := symLength+12; {update length of symbol table} end; {if} end; {GenSymbol} begin {GenSymbols} tpList := nil; {no types so far} if sym <> nil then for i := 0 to hashSize do begin {loop over all hash buckets} ip := sym^.buckets[i]; {trace through all symbols in this bucket} while ip <> nil do begin if ip^.storage <> none then GenSymbol(ip, ip^.storage); ip := ip^.next; {next symbol} end; {while} end; {for} while tpList <> nil do begin {dispose of type list} tp2 := tpList; tpList := tp2^.next; dispose(tp2); end; {while} if doGlobals then {do globals} GenSymbols(globalTable, false); end; {GenSymbols} procedure InitSymbol; { Initialize the symbol table module } var i: 0..hashSize; {loop variable} begin {InitSymbol} staticNum := '~0000'; {no functions processed} table := nil; {initialize the global symbol table} PushTable; globalTable := table; noDeclarations := false; {declare base types} new(bytePtr); {byte} with bytePtr^ do begin size := cgByteSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgByte; end; {with} new(uBytePtr); {unsigned byte} with uBytePtr^ do begin size := cgByteSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgUByte; end; {with} new(wordPtr); {word} with wordPtr^ do begin size := cgWordSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgWord; end; {with} new(uWordPtr); {unsigned word} with uWordPtr^ do begin size := cgWordSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgUWord; end; {with} new(longPtr); {long} with longPtr^ do begin size := cgLongSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgLong; end; {with} new(uLongPtr); {unsigned long} with uLongPtr^ do begin size := cgLongSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgULong; end; {with} new(realPtr); {real} with realPtr^ do begin size := cgRealSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgReal; end; {with} new(doublePtr); {double} with doublePtr^ do begin size := cgDoubleSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgDouble; end; {with} new(compPtr); {comp} with compPtr^ do begin size := cgCompSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgComp; end; {with} new(extendedPtr); {extended} with extendedPtr^ do begin size := cgExtendedSize; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgExtended; end; {with} new(stringTypePtr); {string constant type} with stringTypePtr^ do begin size := 0; saveDisp := 0; isConstant := false; kind := arrayType; aType := uBytePtr; elements := 1; end; {with} new(voidPtr); {void} with voidPtr^ do begin size := 0; saveDisp := 0; isConstant := false; kind := scalarType; baseType := cgVoid; end; {with} new(voidPtrPtr); {typeless pointer} with voidPtrPtr^ do begin size := 4; saveDisp := 0; isConstant := false; kind := pointerType; pType := voidPtr; end; {with} new(defaultStruct); {default structure} with defaultStruct^ do begin {(for structures with errors)} size := cgWordSize; saveDisp := 0; isConstant := false; kind := structType; sName := nil; new(fieldList); with fieldlist^ do begin next := nil; name := @'field'; itype := wordPtr; class := ident; state := declared; disp := 0; bitdisp := 0; end; {with} end; {with} end; {InitSymbol} function NewSymbol {name: stringPtr; itype: typePtr; class: tokenEnum; space: spaceType; state: stateKind): identPtr}; { insert a new symbol in the symbol table } { } { parameters: } { name - pointer to the symbol name } { itype - pointer to the symbol type } { class - storage class } { space - the kind of variable space to put the } { identifier in } { state - variable declaration state } { } { returns: pointer to the inserted symbol } var cs: identPtr; {current symbol} hashPtr: ^identPtr; {pointer to hash bucket in symbol table} i: integer; {loop variable} isGlobal: boolean; {are we using the global table?} lUseGlobalPool: boolean; {use the global symbol pool?} needSymbol: boolean; {do we need to declare it?} np: stringPtr; {for forming static name} p: identPtr; {work pointer} tk: tokenType; {fake token; for FindSymbol} begin {NewSymbol} needSymbol := true; {assume we need a symbol} cs := nil; {no current symbol found} isGlobal := false; {set up defaults} lUseGlobalPool := useGlobalPool; tk.name := name; tk.symbolPtr := nil; if space <> fieldListSpace then begin {are we defining a function?} if itype^.kind = functionType then begin isGlobal := true; useGlobalPool := true; if class in [autosy, ident] then class := externsy; if not lUseGlobalPool then begin np := pointer(Malloc(length(name^)+1)); CopyString(pointer(np), pointer(name)); tk.name := np; name := np; end; {if} cs := FindSymbol(tk, space, false, true); if cs <> nil then begin if cs^.state = defined then if state = defined then Error(42); p := cs; needSymbol := false; if not itype^.prototyped then begin itype^.prototyped := cs^.itype^.prototyped; itype^.parameterList := cs^.itype^.parameterList; end; {if} end; {if} end {if} else if (itype^.kind in [structType,unionType]) and (itype^.fieldList = nil) and doingParameters then begin isGlobal := true; useGlobalPool := true; end; {else if} if noDeclarations then begin {if we need a symbol table, create it} if not isGlobal then noDeclarations := false; end {if} else begin {check for duplicates} cs := FindSymbol(tk, space, true, false); if cs <> nil then begin if (not CompTypes(cs^.itype, itype)) or ((cs^.state = initialized) and (state = initialized)) or (globalTable <> table) then if (not doingParameters) or (cs^.state <> declared) then Error(42); p := cs; needSymbol := false; end; {if} end; {else} end; {if} if class = staticsy then {statics go in the global symbol table} if not isGLobal then if globalTable <> table then begin cs := FindSymbol(tk, space, true, true); if cs <> nil then begin {check for duplicates} if (not CompTypes(cs^.itype, itype)) or ((cs^.state = defined) and (state <> initialized)) or (cs^.state = initialized) then Error(42); p := cs; needSymbol := false; end; {if} isGlobal := true; {note that we will use the global table} useGlobalPool := true; np := pointer(GMalloc(length(name^)+6)); np^[0] := chr(5+length(name^)); for i := 1 to 5 do np^[i] := table^.staticNum[i]; for i := 1 to length(name^) do np^[i+5] := name^[i]; name := np; end; {if} if needSymbol then begin p := pointer(Calloc(sizeof(identRecord))); {get space for the record} {p^.iPtr := nil;} {no initializers, yet} {p^.saved := 0;} {not saved} p^.state := state; {set the state} {p^.isForwardDeclared := false;} {assume no forward declarations are used} p^.name := name; {record the name} if space <> fieldListSpace then {insert the symbol in the hash bucket} begin if itype = nil then hashPtr := pointer(ord4(table)+Hash(name)) else if isGlobal then hashPtr := pointer(ord4(globalTable)+Hash(name)) else hashPtr := pointer(ord4(table)+Hash(name)); if space = tagSpace then hashPtr := pointer(ord4(hashPtr) + 4*(hashSize+1)); p^.next := hashPtr^; hashPtr^ := p; end {if} else p^.next := nil; end; {if} if class in [autosy,registersy] then {check and set the storage class} begin if doingFunction or doingParameters then begin p^.storage := stackFrame; class := ident; end {if} else begin p^.storage := global; Error(62); end; {else} end {if} else if class = ident then begin if doingFunction then begin p^.storage := stackFrame; class := autosy; end {if} else p^.storage := global; end {else if} else if class = externsy then p^.storage := external else if class = staticsy then p^.storage := private else p^.storage := none; p^.class := class; p^.itype := itype; {set the symbol field values} NewSymbol := p; {return a pointer to the new entry} useGlobalPool := lUseGlobalPool; {restore the useGlobalPool variable} end; {NewSymbol} procedure PopTable; { Pop a symbol table (remove definitions local to a block) } var tPtr: symbolTablePtr; {work pointer} begin {PopTable} tPtr := table; {if printSymbols then {debug} { PrintTable(tPtr); {debug} if tPtr^.next <> nil then begin table := table^.next; dispose(tPtr); end; {if} end; {PopTable} { copy 'symbol.print'} {debug} procedure PushTable; { Create a new symbol table, pushing the old one } var done: boolean; {loop termination} i: integer; {loop index} tPtr: symbolTablePtr; {work pointer} begin {PushTable} i := 5; {increment the static var number} repeat staticNum[i] := succ(staticNum[i]); done := staticNum[i] <> succ('9'); if not done then begin staticNum[i] := '0'; i := i-1; done := i = 1; end; {if} until done; if table = globalTable then {update fistStaticNum} firstStaticNum := staticNum; new(tPtr); {create a new symbol table} ClearTable(tPtr^); tPtr^.next := table; table := tPtr; tPtr^.staticNum := staticNum; {record the static symbol table number} end; {PushTable} procedure ResolveForwardReference {iPtr: identPtr}; { resolve a forward reference } { } { parameters: } { iPtr - ptr to the forward declared identifier } var fl: identPtr; {for tracing field lists} ltk: tokenType; {for searching for forward refs} sym: identPtr; {for finding forward refs} lPtr,tPtr: typePtr; {for tracing forward declared types} begin {ResolveForwardReference} iPtr^.isForwardDeclared := false; {we will succeeed or flag an error...} tPtr := iPtr^.itype; {skip to the struct/union type} while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do begin lPtr := tPtr; tPtr := tPtr^.pType; end; if tPtr^.sName <> nil then begin {resolve the forward reference} ltk.name := tPtr^.sName; ltk.symbolPtr := nil; sym := FindSymbol(ltk,tagSpace,false,true); if sym <> nil then begin if sym^.itype^.kind <> tPtr^.kind then Error(107) else begin if sym^.itype = tPtr then tPtr^.sName := nil else lPtr^.ptype := sym^.itype; end; {else} end; {if} end; {if} tPtr := lPtr^.pType; {check the field list for other fwd refs} while tPtr^.kind in [pointerType,arrayType,functionType,definedType] do tPtr := tPtr^.pType; if tPtr^.kind in [structType,unionType] then begin fl := tPtr^.fieldList; while fl <> nil do begin if fl^.isForwardDeclared then ResolveForwardReference(fl); fl := fl^.next; end; {while} end; {if} end; {ResolveForwardReference} end. {$append 'symbol.asm'} \ No newline at end of file diff --git a/Table.asm b/Table.asm new file mode 100755 index 0000000..8ffcf31 --- /dev/null +++ b/Table.asm @@ -0,0 +1 @@ + mcopy table.macros **************************************************************** * * Table * * This segment contains the assembly language code for the * various initialized arrays and records in the program. This * file creates the object file linked into the program. * TABLE.PAS creates the interface file that informs the * other segments in the compiler what is in this segment. * **************************************************************** * root start dummy (.root) segment end charKinds start character set enum (illegal,ch_special,ch_dash,ch_plus,ch_lt,ch_gt,ch_eq,ch_exc),0 enum (ch_and,ch_bar,ch_dot,ch_white,ch_eol,ch_eof,ch_char,ch_string) enum (ch_asterisk,ch_slash,ch_percent,ch_carot,ch_pound,letter,digit) ! STANDARD dc i'ch_eof' nul dc i'illegal' soh dc i'illegal' stx dc i'illegal' etx dc i'illegal' eot dc i'illegal' enq dc i'illegal' ack dc i'illegal' bel dc i'ch_white' bs dc i'ch_white' ht dc i'ch_eol' lf dc i'ch_eol' vt dc i'ch_eol' ff dc i'ch_eol' cr dc i'illegal' co dc i'illegal' si dc i'illegal' dle dc i'illegal' dc1 dc i'illegal' dc2 dc i'illegal' dc3 dc i'illegal' dc4 dc i'illegal' nak dc i'illegal' syn dc i'illegal' etb dc i'illegal' can dc i'illegal' em dc i'illegal' sub dc i'illegal' esc dc i'illegal' fs dc i'illegal' gs dc i'illegal' rs dc i'illegal' us dc i'ch_white' space dc i'ch_exc' ! dc i'ch_string' " dc i'illegal' # dc i'illegal' $ dc i'ch_percent' % dc i'ch_and' & dc i'ch_char' ' dc i'ch_special' ( dc i'ch_special' ) dc i'ch_asterisk' * dc i'ch_plus' + dc i'ch_special' , dc i'ch_dash' - dc i'ch_dot' . dc i'ch_slash' / dc i'digit' 0 dc i'digit' 1 dc i'digit' 2 dc i'digit' 3 dc i'digit' 4 dc i'digit' 5 dc i'digit' 6 dc i'digit' 7 dc i'digit' 8 dc i'digit' 9 dc i'ch_special' : dc i'ch_special' ; dc i'ch_lt' < dc i'ch_eq' = dc i'ch_gt' > dc i'ch_special' ? dc i'illegal' @ dc i'letter' A dc i'letter' B dc i'letter' C dc i'letter' D dc i'letter' E dc i'letter' F dc i'letter' G dc i'letter' H dc i'letter' I dc i'letter' J dc i'letter' K dc i'letter' L dc i'letter' M dc i'letter' N dc i'letter' O dc i'letter' P dc i'letter' Q dc i'letter' R dc i'letter' S dc i'letter' T dc i'letter' U dc i'letter' V dc i'letter' W dc i'letter' X dc i'letter' Y dc i'letter' Z dc i'ch_special' [ dc i'illegal' \ dc i'ch_special' ] dc i'ch_carot' ^ dc i'letter' _ dc i'illegal' ` dc i'letter' a dc i'letter' b dc i'letter' c dc i'letter' d dc i'letter' e dc i'letter' f dc i'letter' g dc i'letter' h dc i'letter' i dc i'letter' j dc i'letter' k dc i'letter' l dc i'letter' m dc i'letter' n dc i'letter' o dc i'letter' p dc i'letter' q dc i'letter' r dc i'letter' s dc i'letter' t dc i'letter' u dc i'letter' v dc i'letter' w dc i'letter' x dc i'letter' y dc i'letter' z dc i'ch_special' { dc i'ch_bar' | dc i'ch_special' } dc i'ch_special' ~ dc i'illegal' rub ! EXTENDED dc i'letter' nul dc i'letter' soh dc i'letter' stx dc i'letter' etx dc i'letter' eot dc i'letter' enq dc i'letter' ack dc i'letter' bel dc i'letter' bs dc i'letter' ht dc i'letter' lf dc i'letter' vt dc i'letter' ff dc i'letter' cr dc i'letter' co dc i'letter' si dc i'letter' dle dc i'letter' dc1 dc i'letter' dc2 dc i'letter' dc3 dc i'letter' dc4 dc i'letter' nak dc i'letter' syn dc i'letter' etb dc i'letter' can dc i'letter' em dc i'letter' sub dc i'letter' esc dc i'letter' fs dc i'letter' gs dc i'letter' rs dc i'letter' us dc i'illegal' space dc i'illegal' ! dc i'illegal' " dc i'illegal' # dc i'illegal' $ dc i'illegal' % dc i'illegal' & dc i'letter' ' dc i'illegal' ( dc i'illegal' ) dc i'illegal' * dc i'illegal' + dc i'illegal' , dc i'ch_special' - dc i'letter' . dc i'letter' / dc i'illegal' 0 dc i'illegal' 1 dc i'ch_special' 2 dc i'ch_special' 3 dc i'letter' 4 dc i'letter' 5 dc i'letter' 6 dc i'letter' 7 dc i'letter' 8 dc i'letter' 9 dc i'illegal' : dc i'letter' ; dc i'letter' < dc i'letter' = dc i'letter' > dc i'letter' ? dc i'illegal' @ dc i'illegal' A dc i'illegal' B dc i'illegal' C dc i'letter' D dc i'illegal' E dc i'letter' F dc i'ch_special' G dc i'ch_special' H dc i'illegal' I dc i'ch_white' J dc i'letter' K dc i'letter' L dc i'letter' M dc i'letter' N dc i'letter' O dc i'illegal' P dc i'illegal' Q dc i'illegal' R dc i'illegal' S dc i'illegal' T dc i'illegal' U dc i'ch_special' V dc i'illegal' W dc i'letter' X dc i'illegal' Y dc i'illegal' Z dc i'illegal' [ dc i'illegal' \ dc i'illegal' ] dc i'letter' ^ dc i'letter' _ dc i'illegal' ` dc i'illegal' a dc i'illegal' b dc i'illegal' c dc i'illegal' d dc i'illegal' e dc i'illegal' f dc i'illegal' g dc i'illegal' h dc i'illegal' i dc i'illegal' j dc i'illegal' k dc i'illegal' l dc i'illegal' m dc i'illegal' n dc i'illegal' o dc i'illegal' p dc i'illegal' q dc i'illegal' r dc i'illegal' s dc i'illegal' t dc i'illegal' u dc i'illegal' v dc i'illegal' w dc i'illegal' x dc i'illegal' y dc i'illegal' z dc i'illegal' { dc i'illegal' | dc i'illegal' } dc i'illegal' ~ dc i'illegal' rub end charSym start single character symbols enum ident,0 identifiers ! constants enum (intconst,uintconst,longconst,ulongconst,doubleconst) enum stringconst ! reserved words enum (autosy,asmsy,breaksy,casesy,charsy) enum (continuesy,constsy,compsy,defaultsy,dosy) enum (doublesy,elsesy,enumsy,externsy,extendedsy) enum (floatsy,forsy,gotosy,ifsy,intsy) enum (inlinesy,longsy,pascalsy,registersy,returnsy) enum (shortsy,sizeofsy,staticsy,structsy,switchsy) enum (segmentsy,signedsy,typedefsy,unionsy,unsignedsy) enum (voidsy,volatilesy,whilesy) ! reserved symbols enum (excch,percentch,carotch,andch,asteriskch) enum (minusch,plusch,eqch,tildech,barch) enum (dotch,ltch,gtch,slashch,questionch) enum (lparench,rparench,lbrackch,rbrackch,lbracech) enum (rbracech,commach,semicolonch,colonch,poundch) enum (minusgtop,plusplusop,minusminusop,ltltop,gtgtop) enum (lteqop,gteqop,eqeqop,exceqop,andandop) enum (barbarop,pluseqop,minuseqop,asteriskeqop,slasheqop) enum (percenteqop,ltlteqop,gtgteqop,andeqop,caroteqop) enum (bareqop,poundpoundop) enum (eolsy,eofsy) control characters enum (typedef) user types enum (uminus,uand,uasterisk) converted operations enum (parameteroper,castoper,opplusplus,opminusminus) enum (macroParm) macro language dc i'0,0,0,0,0,0,0,0' nul-bel dc i'0,0,0,0,0,0,0,0' bs-si dc i'0,0,0,0,0,0,0,0' dle-etb dc i'0,0,0,0,0,0,0,0' can-us dc i'0,0,0,poundch,0,0,0,0' space-' dc i'lparench,rparench,0,0,commach,0,dotch,0' (-/ dc i'0,0,0,0,0,0,0,0' 0-7 dc i'0,0,colonch,semicolonch,0,0,0,questionch' 8-? dc i'0,0,0,0,0,0,0,0' @-G dc i'0,0,0,0,0,0,0,0' H-O dc i'0,0,0,0,0,0,0,0' P-W dc i'0,0,0,lbrackch,0,rbrackch,0,0' X-_ dc i'0,0,0,0,0,0,0,0' `-g dc i'0,0,0,0,0,0,0,0' h-o dc i'0,0,0,0,0,0,0,0' p-w dc i'0,0,0,lbracech,0,rbracech,tildech,0' x-rub dc i'0,0,0,0,0,0,0,0' nul-bel dc i'0,0,0,0,0,0,0,0' bs-si dc i'0,0,0,0,0,0,0,0' dle-etb dc i'0,0,0,0,0,0,0,0' can-us dc i'0,0,0,0,0,0,0,0' space-' dc i'0,0,0,0,0,exceqop,0,0' (-/ dc i'0,0,lteqop,gteqop,0,0,0,0' 0-7 dc i'0,0,0,0,0,0,0,0' 8-? dc i'0,0,0,0,0,0,0,ltltop' @-G dc i'gtgtop,0,0,0,0,0,0,0' H-O dc i'0,0,0,0,0,0,slashch,0' P-W dc i'0,0,0,0,0,0,0,0' X-_ dc i'0,0,0,0,0,0,0,0' `-g dc i'0,0,0,0,0,0,0,0' h-o dc i'0,0,0,0,0,0,0,0' p-w dc i'0,0,0,0,0,0,0,0' x-rub end icp start in comming priority for expression ! assumes notAnOperation = 200 dc i1'200' ident dc i1'200' intconst dc i1'200' uintconst dc i1'200' longconst dc i1'200' ulongconst dc i1'200' doubleconst dc i1'200' stringconst dc i1'200' autosy dc i1'200' asmsy dc i1'200' breaksy dc i1'200' casesy dc i1'200' charsy dc i1'200' continuesy dc i1'200' constsy dc i1'200' compsy dc i1'200' defaultsy dc i1'200' dosy dc i1'200' doublesy dc i1'200' elsesy dc i1'200' enumsy dc i1'200' externsy dc i1'200' extendedsy dc i1'200' floatsy dc i1'200' forsy dc i1'200' gotosy dc i1'200' ifsy dc i1'200' intsy dc i1'200' inlinesy dc i1'200' longsy dc i1'200' pascalsy dc i1'200' registersy dc i1'200' returnsy dc i1'200' shortsy dc i1'16' sizeofsy dc i1'200' staticsy dc i1'200' structsy dc i1'200' switchsy dc i1'200' segmentsy dc i1'200' signedsy dc i1'200' typedefsy dc i1'200' unionsy dc i1'200' unsignedsy dc i1'200' voidsy dc i1'200' volatilesy dc i1'200' whilesy dc i1'16' excch dc i1'15' percentch dc i1'9' carotch dc i1'10' andch dc i1'15' asteriskch dc i1'14' minusch dc i1'14' plusch dc i1'3' eqch dc i1'16' tildech dc i1'8' barch dc i1'200' dotch dc i1'12' ltch dc i1'12' gtch dc i1'15' slashch dc i1'5' questionch dc i1'16' lparench dc i1'200' rparench dc i1'200' lbrackch dc i1'200' rbrackch dc i1'200' lbracech dc i1'200' rbracech dc i1'1' commach dc i1'200' semicolonch dc i1'5' colonch dc i1'200' poundch dc i1'200' minusgtop dc i1'16' plusplusop dc i1'16' minusminusop dc i1'13' ltltop dc i1'13' gtgtop dc i1'12' lteqop dc i1'12' gteqop dc i1'11' eqeqop dc i1'11' exceqop dc i1'7' andandop dc i1'6' barbarop dc i1'3' pluseqop dc i1'3' minuseqop dc i1'3' asteriskeqop dc i1'3' slasheqop dc i1'3' percenteqop dc i1'3' ltlteqop dc i1'3' gtgteqop dc i1'3' andeqop dc i1'3' caroteqop dc i1'3' bareqop dc i1'200' poundpoundop dc i1'200' eolsy dc i1'200' eofsy dc i1'200' typedef dc i1'16' uminus dc i1'16' uand dc i1'16' uasterisk dc i1'200' parameteroper dc i1'16' castoper dc i1'16' opplusplus dc i1'16' opminusminus dc i1'200' macroParm end iopcodes start implied operand operation codes dc i1'$18' clc dc i1'$D8' cld dc i1'$58' cli dc i1'$B8' clv dc i1'$CA' dex dc i1'$88' dey dc i1'$E8' inx dc i1'$C8' iny dc i1'$EA' nop dc i1'$48' pha dc i1'$8B' phb dc i1'$0B' phd dc i1'$4B' phk dc i1'$08' php dc i1'$DA' phx dc i1'$5A' phy dc i1'$68' pla dc i1'$AB' plb dc i1'$2B' pld dc i1'$28' plp dc i1'$FA' plx dc i1'$7A' ply dc i1'$40' rti dc i1'$6B' rtl dc i1'$60' rts dc i1'$38' sec dc i1'$F8' sed dc i1'$78' sei dc i1'$DB' stp dc i1'$AA' tax dc i1'$A8' tay dc i1'$5B' tcd dc i1'$1B' tcs dc i1'$7B' tdc dc i1'$3B' tsc dc i1'$BA' tsx dc i1'$8A' txa dc i1'$9A' txs dc i1'$9B' txy dc i1'$98' tya dc i1'$BB' tyx dc i1'$CB' wai dc i1'$EB' xba dc i1'$FB' xce end isp start in stack priority for expression dc i1'0' ident dc i1'0' intconst dc i1'0' uintconst dc i1'0' longconst dc i1'0' ulongconst dc i1'0' doubleconst dc i1'0' stringconst dc i1'0' autosy dc i1'0' asmsy dc i1'0' breaksy dc i1'0' casesy dc i1'0' charsy dc i1'0' continuesy dc i1'0' constsy dc i1'0' compsy dc i1'0' defaultsy dc i1'0' dosy dc i1'0' doublesy dc i1'0' elsesy dc i1'0' enumsy dc i1'0' externsy dc i1'0' extendedsy dc i1'0' floatsy dc i1'0' forsy dc i1'0' gotosy dc i1'0' ifsy dc i1'0' intsy dc i1'0' inlinesy dc i1'0' longsy dc i1'0' pascalsy dc i1'0' registersy dc i1'0' returnsy dc i1'0' shortsy dc i1'16' sizeofsy dc i1'0' staticsy dc i1'0' structsy dc i1'0' switchsy dc i1'0' segmentsy dc i1'0' signedsy dc i1'0' typedefsy dc i1'0' unionsy dc i1'0' unsignedsy dc i1'0' voidsy dc i1'0' volatilesy dc i1'0' whilesy dc i1'16' excch dc i1'15' percentch dc i1'9' carotch dc i1'10' andch dc i1'15' asteriskch dc i1'14' minusch dc i1'14' plusch dc i1'2' eqch dc i1'16' tildech dc i1'8' barch dc i1'0' dotch dc i1'12' ltch dc i1'12' gtch dc i1'15' slashch dc i1'0' questionch dc i1'0' lparench dc i1'0' rparench dc i1'0' lbrackch dc i1'0' rbrackch dc i1'0' lbracech dc i1'0' rbracech dc i1'1' commach dc i1'0' semicolonch dc i1'4' colonch dc i1'0' poundch dc i1'0' minusgtop dc i1'16' plusplusop dc i1'16' minusminusop dc i1'13' ltltop dc i1'13' gtgtop dc i1'12' lteqop dc i1'12' gteqop dc i1'11' eqeqop dc i1'11' exceqop dc i1'7' andandop dc i1'6' barbarop dc i1'2' pluseqop dc i1'2' minuseqop dc i1'2' asteriskeqop dc i1'2' slasheqop dc i1'2' percenteqop dc i1'2' ltlteqop dc i1'2' gtgteqop dc i1'2' andeqop dc i1'2' caroteqop dc i1'2' bareqop dc i1'0' poundpoundop dc i1'0' eolsy dc i1'0' eofsy dc i1'0' typedef dc i1'16' uminus dc i1'16' uand dc i1'16' uasterisk dc i1'0' parameteroper dc i1'16' castoper dc i1'16' opplusplus dc i1'16' opminusminus dc i1'0' macroParm end names start mini-assembler op code names dc c'adcandaslbitcmpcopcpxcpydeceor' dc c'incjmljmpjsljsrldaldxldylsrora' dc c'peapeireprolrorsbcsepstastxsty' dc c'stztrbtsb' dc c'dcbdcwdcl' dc c'brk' dc c'mvnmvp' dc c'bccbcsbeqbmibnebplbrabrlperbvc' dc c'bvs' dc c'clccldcliclvdexdeyinxinynoppha' dc c'phbphdphkphpphxphyplaplbpldplp' dc c'plxplyrtirtlrtssecsedseistptax' dc c'taytcdtcstdctsctsxtxatxstxytya' dc c'tyxwaixbaxce' end nopcodes start ! acc imm dp dp_x dp_y operand order ! op op_x op_y i_dp_x i_dp_y ! dp_s li_dp la i_dp i_op ! i_la i_op_x i_dp_s_y li_dp_y long_x dc i1'0 ,$69 ,$65 ,$75 ,0 ' adc dc i1'$6D ,$7D ,$79 ,$61 ,$71 ' dc i1'$63 ,$67 ,$6F ,$72 ,0 ' dc i1'0 ,0 ,$73 ,$77 ,$7F ' dc i1'0 ,$29 ,$25 ,$35 ,0 ' and dc i1'$2D ,$3D ,$39 ,$21 ,$31 ' dc i1'$23 ,$27 ,$2F ,$32 ,0 ' dc i1'0 ,0 ,$33 ,$37 ,$3F ' dc i1'$0A ,0 ,$06 ,$16 ,0 ' asl dc i1'$0E ,$1E ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$89 ,$24 ,$34 ,0 ' bit dc i1'$2C ,$3C ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$C9 ,$C5 ,$D5 ,0 ' cmp dc i1'$CD ,$DD ,$D9 ,$C1 ,$D1 ' dc i1'$C3 ,$C7 ,$CF ,$D2 ,0 ' dc i1'0 ,0 ,$D3 ,$D7 ,$DF ' dc i1'0 ,0 ,$02 ,0 ,0 ' cop dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$E0 ,$E4 ,0 ,0 ' cpx dc i1'$EC ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$C0 ,$C4 ,0 ,0 ' cpy dc i1'$CC ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'$3A ,0 ,$C6 ,$D6 ,0 ' dec dc i1'$CE ,$DE ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$49 ,$45 ,$55 ,0 ' eor dc i1'$4D ,$5D ,$59 ,$41 ,$51 ' dc i1'$43 ,$47 ,$4F ,$52 ,0 ' dc i1'0 ,0 ,$53 ,$57 ,$5F ' dc i1'$1A ,0 ,$E6 ,$F6 ,0 ' inc dc i1'$EE ,$FE ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' jml dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$5C ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' jmp dc i1'$4C ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$5C ,0 ,$6C ' dc i1'$DC ,$7C ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' jsl dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$22 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' jsr dc i1'$20 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$22 ,0 ,0 ' dc i1'0 ,$FC ,0 ,0 ,0 ' dc i1'0 ,$A9 ,$A5 ,$B5 ,0 ' lda dc i1'$AD ,$BD ,$B9 ,$A1 ,$B1 ' dc i1'$A3 ,$A7 ,$AF ,$B2 ,0 ' dc i1'0 ,0 ,$B3 ,$B7 ,$BF ' dc i1'0 ,$A2 ,$A6 ,0 ,$B6 ' ldx dc i1'$AE ,0 ,$BE ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$A0 ,$A4 ,$B4 ,0 ' ldy dc i1'$AC ,$BC ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'$4A ,0 ,$46 ,$56 ,0 ' lsr dc i1'$4E ,$5E ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$09 ,$05 ,$15 ,0 ' ora dc i1'$0D ,$1D ,$19 ,$01 ,$11 ' dc i1'$03 ,$07 ,$0F ,$12 ,0 ' dc i1'0 ,0 ,$13 ,$17 ,$1F ' dc i1'0 ,0 ,0 ,0 ,0 ' pea dc i1'$F4 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$D4 ,0 ,0 ' pei dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,$D4 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$C2 ,0 ,0 ,0 ' rep dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'$2A ,0 ,$26 ,$36 ,0 ' rol dc i1'$2E ,$3E ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'$6A ,0 ,$66 ,$76 ,0 ' ror dc i1'$6E ,$7E ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,$E9 ,$E5 ,$F5 ,0 ' sbc dc i1'$ED ,$FD ,$F9 ,$E1 ,$F1 ' dc i1'$E3 ,$E7 ,$EF ,$F2 ,0 ' dc i1'0 ,0 ,$F3 ,$F7 ,$FF ' dc i1'0 ,$E2 ,0 ,0 ,0 ' sep dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$85 ,$95 ,0 ' sta dc i1'$8D ,$9D ,$99 ,$81 ,$91 ' dc i1'$83 ,$87 ,$8F ,$92 ,0 ' dc i1'0 ,0 ,$93 ,$97 ,$9F ' dc i1'0 ,0 ,$86 ,0 ,$96 ' stx dc i1'$8E ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$84 ,$94 ,0 ' sty dc i1'$8C ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$64 ,$74 ,0 ' stz dc i1'$9C ,$9E ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$14 ,0 ,0 ' trb dc i1'$1C ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,$04 ,0 ,0 ' tsb dc i1'$0C ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' dc i1'0 ,0 ,0 ,0 ,0 ' end reservedWords start reserved word names str8 auto str8 asm str8 break str8 case str8 char str8 continue str8 const str8 comp str8 default str8 do str8 double str8 else str8 enum str8 extern str8 extended str8 float str8 for str8 goto str8 if str8 int str8 inline str8 long str8 pascal str8 register str8 return str8 short str8 sizeof str8 static str8 struct str8 switch str8 segment str8 signed str8 typedef str8 union str8 unsigned str8 void str8 volatile str8 while end ropcodes start dc i1'$90' bcc dc i1'$B0' bcs dc i1'$F0' beq dc i1'$30' bmi dc i1'$D0' bne dc i1'$10' bpl dc i1'$80' bra dc i1'$82' brl dc i1'$62' per dc i1'$50' bvc dc i1'$70' bvs end wordHash start reserved word hash table enum ident,0 identifiers ! constants enum (intconst,uintconst,longconst,ulongconst,doubleconst) enum stringconst ! reserved words enum (autosy,asmsy,breaksy,casesy,charsy) enum (continuesy,constsy,compsy,defaultsy,dosy) enum (doublesy,elsesy,enumsy,externsy,extendedsy) enum (floatsy,forsy,gotosy,ifsy,intsy) enum (inlinesy,longsy,pascalsy,registersy,returnsy) enum (shortsy,sizeofsy,staticsy,structsy,switchsy) enum (segmentsy,signedsy,typedefsy,unionsy,unsignedsy) enum (voidsy,volatilesy,whilesy,succwhilesy) dc i'autosy,breaksy,casesy,defaultsy,elsesy,floatsy' dc i'gotosy,ifsy,ifsy,longsy,longsy,longsy' dc i'pascalsy,pascalsy,pascalsy,pascalsy,registersy,registersy' dc i'shortsy,typedefsy,unionsy,voidsy,whilesy,succwhilesy' end \ No newline at end of file diff --git a/Table.macros b/Table.macros new file mode 100755 index 0000000..e4f329a --- /dev/null +++ b/Table.macros @@ -0,0 +1 @@ + MACRO &LAB ENUM &LIST,&START &LAB ANOP AIF C:&~ENUM,.A GBLA &~ENUM .A AIF C:&START=0,.B &~ENUM SETA &START .B LCLA &CNT &CNT SETA 1 .C &LIST(&CNT) EQU &~ENUM &~ENUM SETA &~ENUM+1 &CNT SETA &CNT+1 AIF &CNT<=C:&LIST,^C MEND MACRO &LAB STR8 &STR &LAB DC I1'L:A&SYSCNT' A&SYSCNT DC C'&STR' DS 8-L:A&SYSCNT MEND \ No newline at end of file diff --git a/Table.pas b/Table.pas new file mode 100755 index 0000000..64fe3d0 --- /dev/null +++ b/Table.pas @@ -0,0 +1 @@ +{$optimize 7} {---------------------------------------------------------------} { } { Table } { } { Initialized arrays and records. } { } {---------------------------------------------------------------} unit Table; {$LibPrefix '0/obj/'} interface uses CCommon; var {from scanner.pas} {----------------} charKinds: array[minChar..maxChar] of charEnum; {character kinds} charSym: array[minChar..maxChar] of tokenEnum; {symbols for single char symbols} reservedWords: array[autosy..whilesy] of string[8]; {reserved word strings} wordHash: array[0..23] of tokenEnum; {for hashing reserved words} {from ASM.PAS} {------------} {names of the opcodes} names: array[opcode] of packed array[1..3] of char; {binary values for the opcodes} iOpcodes: array[o_clc..o_xce] of byte; rOpcodes: array[o_bcc..o_bvs] of byte; nOpcodes: array[o_adc..o_tsb,operands] of byte; {from EXPRESSION.PAS} {-------------------} icp: array[tokenEnum] of byte; {in-commong priorities} isp: array[tokenEnum] of byte; {in-stack priorities} implementation end. \ No newline at end of file diff --git a/Tests/Conformance/C11.4.2.1.CC b/Tests/Conformance/C11.4.2.1.CC new file mode 100755 index 0000000..67dfd76 --- /dev/null +++ b/Tests/Conformance/C11.4.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 11.4.2.1: Type qualifiers should be allowed both in */ /* type casts and in the type-specifiers for */ /* field lists. */ #include struct foo { int i; const j; volatile k; } ; main () { int i,j; j = 4; i = (const) j; i = (volatile) j; printf ("Passed Conformance Test 11.4.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C13.1.0.1.CC b/Tests/Conformance/C13.1.0.1.CC new file mode 100755 index 0000000..986bb2e --- /dev/null +++ b/Tests/Conformance/C13.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 13.1.0.1: Verification of standard library types and */ /* NULL */ #include extended e1 [800]; main () { int i [10] = { 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 }; int *i1 = i; int *i2 = &i [2]; long diff; unsigned long size; static ptrdiff_t TestPtrdiff_t (int *int1Ptr, int *int2Ptr); diff = TestPtrdiff_t (i2, i1); if (diff != 2) goto Fail; size = sizeof(e1); if (size != 8000) goto Fail; if (NULL != 0) goto Fail; printf ("Passed Conformance Test 13.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 13.1.0.1\n"); } /*****************************************************************************/ static ptrdiff_t TestPtrdiff_t (int *int1Ptr, int *int2Ptr) { return int1Ptr - int2Ptr; } \ No newline at end of file diff --git a/Tests/Conformance/C14.1.0.1.CC b/Tests/Conformance/C14.1.0.1.CC new file mode 100755 index 0000000..f6363f0 --- /dev/null +++ b/Tests/Conformance/C14.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.1.0.1: Verification of isalnum, isalpha, isascii, */ /* and iscntrl */ #include main () { int i, j; char ch; short k; long L; unsigned int ui1; unsigned long ul1; unsigned char uc; /* isalnum: returns 0 if char is not in ['0'..'9', 'a'..'z', 'A'..'Z'] */ for (ch = '0'; ch <= '9'; ch++) { j = isalnum (ch); if (j == 0) goto Fail; } for (uc = 'a'; uc <= 'z'; uc++) { j = isalnum (uc); if (j == 0) goto Fail; } for (uc = 'A'; uc <= 'Z'; uc++) { j = isalnum (uc); if (j == 0) goto Fail; } j = isalnum ('~'); if (j != 0) goto Fail; /* isalpha: returns 0 if char is not in ['a'..'z', 'A'..'Z'] */ for (ch = '0'; ch <= '9'; ch++) { j = isalpha (ch); if (j != 0) goto Fail; } for (uc = 'a'; uc <= 'z'; uc++) { j = isalpha (uc); if (j == 0) goto Fail; } for (uc = 'A'; uc <= 'Z'; uc++) { j = isalpha (uc); if (j == 0) goto Fail; } j = isalpha ('~'); if (j != 0) goto Fail; /* isascii: returns 0 if int is not in the range 0..128 */ for (k = 0, i = 0; i < 20; k++, i++) { j = isascii (k); if (j == 0) goto Fail; } for (uc = 20, i = 20; i < 39; uc++, i++) { j = isascii (uc); if (j == 0) goto Fail; } for (ch = 39, i = 39; i < 57; ch++, i++) { j = isascii (ch); if (j == 0) goto Fail; } for (L = 57, i = 57; i < 75; L++, i++) { j = isascii (L); if (j == 0) goto Fail; } for (ui1 = 75, i = 75; i < 93; ui1++, i++) { j = isascii (ui1); if (j == 0) goto Fail; } for (ul1 = 93, i = 93; i < 128; ul1++, i++) { j = isascii (ul1); if (j == 0) goto Fail; } for (i = 128; i < 256; i++) { j = isascii (i); if (j != 0) goto Fail; } /* iscntrl: returns 0 if char is not in [0..31, 127] */ for (i = 0; i <= 31; i++) { j = iscntrl ( (char) (i) ); if (j == 0) goto Fail; } if ( (j = iscntrl (127)) == 0 ) goto Fail; for (i = 32; i < 127; i++) { if ( (j = iscntrl ( (char) (i) )) != 0 ) goto Fail; } printf ("Passed Conformance Test 14.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.2.0.1.CC b/Tests/Conformance/C14.2.0.1.CC new file mode 100755 index 0000000..6bfd2e8 --- /dev/null +++ b/Tests/Conformance/C14.2.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.2.0.1: Verification of iscsym, iscymf */ #include main () { int i, j; char ch; unsigned char uc; /* iscsym: returns 0 if char is not in ['0'..'9', 'a'..'z', 'A'..'Z', '_'] */ /* iscsymf: returns 0 if char is not in ['a'..'z', 'A'..'Z', '_'] */ for (ch = '0'; ch <= '9'; ch++) { j = iscsym (ch); if (j == 0) goto Fail; j = iscsymf (ch); if (j != 0) goto Fail; } for (uc = 'a'; uc <= 'z'; uc++) { j = iscsym (uc); if (j == 0) goto Fail; j = iscsymf (uc); if (j == 0) goto Fail; } for (uc = 'A'; uc <= 'Z'; uc++) { j = iscsym (uc); if (j == 0) goto Fail; j = iscsymf (uc); if (j == 0) goto Fail; } j = iscsym ('_'); if (j == 0) goto Fail; j = iscsymf ('_'); if (j == 0) goto Fail; j = iscsym ('~'); if (j != 0) goto Fail; printf ("Passed Conformance Test 14.2.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.3.0.1.CC b/Tests/Conformance/C14.3.0.1.CC new file mode 100755 index 0000000..32ca3fb --- /dev/null +++ b/Tests/Conformance/C14.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.3.0.1: Verification of isdigit, isodigit, isxdigit */ #include main () { int i, j; char ch; unsigned char uc; /* isdigit: returns 0 if char is not in ['0'..'9'] */ /* isodigit: returns 0 if char is not in ['0'..'7'] */ /* isxdigit: returns 0 if char is not in ['0'..'9', 'a'..'f', 'A'..'F'] */ for (ch = '0'; ch < '8'; ch++) { j = isdigit (ch); if (j == 0) goto Fail; j = isodigit (ch); if (j == 0) goto Fail; j = isxdigit (ch); if (j == 0) goto Fail; } for (ch = '8'; ch <= '9'; ch++) { j = isdigit (ch); if (j == 0) goto Fail; j = isodigit (ch); if (j != 0) goto Fail; j = isxdigit (ch); if (j == 0) goto Fail; } for (uc = 'a'; uc <= 'f'; uc++) { j = isdigit (uc); if (j != 0) goto Fail; j = isodigit (uc); if (j != 0) goto Fail; j = isxdigit (uc); if (j == 0) goto Fail; } for (uc = 'A'; uc <= 'F'; uc++) { j = isdigit (uc); if (j != 0) goto Fail; j = isodigit (uc); if (j != 0) goto Fail; j = isxdigit (uc); if (j == 0) goto Fail; } for (uc = 'G'; uc <= 'Z'; uc++) { j = isdigit (uc); if (j != 0) goto Fail; j = isodigit (uc); if (j != 0) goto Fail; j = isxdigit (uc); if (j != 0) goto Fail; } printf ("Passed Conformance Test 14.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.5.0.1.CC b/Tests/Conformance/C14.5.0.1.CC new file mode 100755 index 0000000..4aa691f --- /dev/null +++ b/Tests/Conformance/C14.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.5.0.1: Verification of islower, isupper */ #include main () { int i, j; char ch; unsigned char uc; /* islower: returns 0 if char is not in ['a'..'z'] */ /* isupper: returns 0 if char is not in ['A'..'Z'] */ for (uc = 'a'; uc <= 'z'; uc++) { j = islower (uc); if (j == 0) goto Fail; j = isupper (uc); if (j != 0) goto Fail; } for (ch = 'A'; ch <= 'Z'; ch++) { j = islower (ch); if (j != 0) goto Fail; j = isupper (ch); if (j == 0) goto Fail; } printf ("Passed Conformance Test 14.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.6.0.1.CC b/Tests/Conformance/C14.6.0.1.CC new file mode 100755 index 0000000..7a6bdd6 --- /dev/null +++ b/Tests/Conformance/C14.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.6.0.1: Verification of isspace function */ #include main () { int i, j; char ch; unsigned char uc; /* isspace: returns 0 if char is not in [ \t \r \n \v \f] */ j = isspace (' '); if (j == 0) goto Fail; for (uc = 9; uc <= '\r'; uc++) { j = isspace (uc); if (j == 0) goto Fail; } for (ch = 'A'; ch <= 'Z'; ch++) { j = isspace (ch); if (j != 0) goto Fail; } printf ("Passed Conformance Test 14.6.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.7.0.1.CC b/Tests/Conformance/C14.7.0.1.CC new file mode 100755 index 0000000..7c7c189 --- /dev/null +++ b/Tests/Conformance/C14.7.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.7.0.1: Verification of toascii function */ #include main () { int i, j; char ch; short k; long L; unsigned int ui1; unsigned long ul1; unsigned char uc; /* toascii: returns ASCII value of any integral value by returning only */ /* the 7 low order bits */ for (k = 0, i = 0; i < 20; k++, i++) { j = toascii (k); if (j != k) goto Fail; } for (uc = 20, i = 20; i < 39; uc++, i++) { j = toascii (uc); if (j != uc) goto Fail; } for (ch = 39, i = 39; i < 57; ch++, i++) { j = toascii (ch); if (j != ch) goto Fail; } for (L = 57, i = 57; i < 75; L++, i++) { j = toascii (L); if (j != L) goto Fail; } for (ui1 = 75, i = 75; i < 93; ui1++, i++) { j = toascii (ui1); if (j != ui1) goto Fail; } for (ul1 = 93, i = 93; i < 128; ul1++, i++) { j = toascii (ul1); if (j != ul1) goto Fail; } for (k = 0, i = 128; i < 256; k++, i++) /* check truncation */ { j = toascii (i); if (j != k) goto Fail; } printf ("Passed Conformance Test 14.7.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.7.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.8.0.1.CC b/Tests/Conformance/C14.8.0.1.CC new file mode 100755 index 0000000..6531104 --- /dev/null +++ b/Tests/Conformance/C14.8.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.8.0.1: Verification of toint function */ #include #include main () { int i, j; char ch; unsigned char uc; /* toint: returns 0-9 for char in ['0'..'9'] and 10-15 for char in */ /* ['a'..'f'] or ['A'..'F'] */ for (uc = '0', i = 0; i < 10; uc++, i++) { j = toint (uc); if (j != i) goto Fail; } for (ch = 'A', i = 10; ch <= 'F'; ch++, i++) { j = toint (ch); if (j != i) goto Fail; } for (ch = 'a', i = 10; ch <= 'f'; ch++, i++) { j = toint (ch); if (j != i) goto Fail; } for (ch = 'G'; ch <= 'Z'; ch++) { j = toint (ch); if (j != EOF) goto Fail; } printf ("Passed Conformance Test 14.8.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.8.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C14.9.0.1.CC b/Tests/Conformance/C14.9.0.1.CC new file mode 100755 index 0000000..1df27aa --- /dev/null +++ b/Tests/Conformance/C14.9.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 14.9.0.1: Verification of tolower, _tolower, toupper, */ /* _toupper functions */ #include main () { int i, j; char ch; unsigned char uc; /* tolower: converts uppercase letter to lowercase letter; if character */ /* is not alphabetic, then just returns character unchanged */ for (ch = 'A', uc = 'a'; uc <= 'z'; ch++, uc++) { j = tolower (ch); if (j != uc) goto Fail; j = _tolower (ch); if (j != uc) goto Fail; j = tolower (uc); if (j != uc) goto Fail; j = _tolower (uc); if (j != uc) goto Fail; } /* toupper: converts lowercase letter to uppercase letter; if character */ /* is not alphabetic, then just returns character unchanged */ for (ch = 'A', uc = 'a'; uc <= 'z'; ch++, uc++) { j = toupper (uc); if (j != ch) goto Fail; j = _toupper (uc); if (j != ch) goto Fail; j = toupper (ch); if (j != ch) goto Fail; j = _toupper (ch); if (j != ch) goto Fail; } printf ("Passed Conformance Test 14.9.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.9.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.1.0.1.CC b/Tests/Conformance/C15.1.0.1.CC new file mode 100755 index 0000000..1213ca7 --- /dev/null +++ b/Tests/Conformance/C15.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.1.0.1: Verification of strcat, strncat functions */ #include main () { char s1 [80] = "this is the first string argument"; char s2 [80] = ", and this is the second string argument!"; char s3 [160] = ""; strcpy(s3, strcat (s1, s2)); if (strlen (s3) != 74) goto Fail; if (strcmp (s3, "this is the first string argument, and this is the \ second string argument!")) goto Fail; strcpy(s1, "this is the first string argument"); strcpy(s3, strncat (s1, s2, 17)); if (strlen (s3) != 50) goto Fail; if (strcmp (s3, "this is the first string argument, and this is the")) goto Fail; strcpy(s1, "this is the first string argument"); strcpy(s3, strncat (s1, s2, 50)); if (strlen (s3) != 74) goto Fail; if (strcmp (s3, "this is the first string argument, and this is the \ second string argument!")) goto Fail; strcpy(s1, "this is the first string argument"); strcpy(s1, strncat (s1, s2, -5)); if (strcmp (s1, "this is the first string argument")) goto Fail; printf ("Passed Conformance Test 15.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.2.0.1.CC b/Tests/Conformance/C15.2.0.1.CC new file mode 100755 index 0000000..ddd3288 --- /dev/null +++ b/Tests/Conformance/C15.2.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.2.0.1: Verification of strcmp, strncmp functions */ #include main () { int i; char s1 [] = "this is a string argument "; char s2 [] = "this is a string argument!"; char s3 [160] = ""; i = strcmp (s1, s2); /* ensure strcmp reports s1 < s2 */ if (i >= 0) goto Fail; i = strcmp (s2, s1); if (i <= 0) goto Fail; i = strncmp (s1, s2, 100); /* should compare all chars */ if (i >= 0) goto Fail; i = strncmp (s1, s2, 25); /* should compare 1st 25 chars */ if (i != 0) goto Fail; i = strncmp (s1, s2, -90L); /* should just return 0 */ if (i != 0) goto Fail; printf ("Passed Conformance Test 15.2.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.3.0.1.CC b/Tests/Conformance/C15.3.0.1.CC new file mode 100755 index 0000000..2179959 --- /dev/null +++ b/Tests/Conformance/C15.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.3.0.1: Verification of strcpy, strncpy functions */ #include #include main () { char s1 [80] = "this is the first string argument"; char s2 [80] = ", and this is the second string argument!"; char *strPtr; size_t i; strPtr = strcpy (s1, s2); if (( (i = strlen (strPtr)) != 41 ) || (strPtr != s1)) goto Fail; if (strcmp (s1, ", and this is the second string argument!")) goto Fail; strcpy(s1, "this is the first string argument"); strPtr = strncpy (s1, s2, 10); if (( (i = strlen (strPtr)) != 33 ) || (strPtr != s1)) goto Fail; if (strcmp (s1, ", and thise first string argument")) goto Fail; strcpy (s1, ", and thise first string argument"); strPtr = strncpy (s1, s2, -9L); if (( (i = strlen (strPtr)) != 33 ) || (strPtr != s1)) goto Fail; if (strcmp (s1, ", and thise first string argument")) goto Fail; printf ("Passed Conformance Test 15.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.5.0.1.CC b/Tests/Conformance/C15.5.0.1.CC new file mode 100755 index 0000000..15b862a --- /dev/null +++ b/Tests/Conformance/C15.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.5.0.1: Verification of strchr, strpos, strrchr, and */ /* strrpos functions */ #include #include main () { char s1 [80] = "this is the first string argument"; char *strPtr; size_t i; strPtr = strchr (s1, 's'); /* search s1 for 1st occurrence of 's' */ if (strPtr == NULL) goto Fail; if (strPtr != &(s1 [3])) goto Fail; strPtr = strchr (s1, 'z'); /* search s1 for char not in s1 */ if (strPtr != NULL) goto Fail; i = strpos (s1, 'f'); /* find position of 1st 'f' in s1 */ if (i != 12) goto Fail; i = strpos (s1, 'x'); /* find position of char not in s1 */ if (i != -1) goto Fail; i = strpos (s1, '\0'); /* find position of terminating null */ if (i != 33) goto Fail; strPtr = strrchr (s1, 's'); /* search s1 for last occurrence of 's' */ if (strPtr == NULL) goto Fail; if (strPtr != &(s1 [18])) goto Fail; strPtr = strrchr (s1, 'z'); /* search s1 for char not in s1 */ if (strPtr != NULL) goto Fail; i = strrpos (s1, 'g'); /* find position of last 'g' in s1 */ if (i != 27) goto Fail; i = strrpos (s1, 'x'); /* find position of char not in s1 */ if (i != -1) goto Fail; i = strrpos (s1, '\0'); /* find position of terminating null */ if (i != 33) goto Fail; printf ("Passed Conformance Test 15.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.6.0.1.CC b/Tests/Conformance/C15.6.0.1.CC new file mode 100755 index 0000000..a8bd28c --- /dev/null +++ b/Tests/Conformance/C15.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.6.0.1: Verification of strspn, strcspn, strpbrk, and */ /* strrpbrk functions */ #include #include main () { char s1 [80] = "a b c d e f g h i j k : ' - _ + "; char *strPtr; size_t i; /* strspn: find length of first run of chars from set */ i = strspn (s1, " abcde cbad "); /* search s1 for only chars in set */ if (i != 10) goto Fail; i = strspn (s1, " +_-':kjihgfedcba"); /* all chars in set are in s1 */ if (i != 32) /* should return length (s1) */ goto Fail; i = strspn (s1, ""); /* should return 0 */ if (i != 0) goto Fail; /* strcspn: find length of first run of chars not in set */ i = strcspn (s1, "fg:"); /* search s1 for chars not in set */ if (i != 10) goto Fail; i = strcspn (s1, " +_-':kjihgfedcba"); /* all chars in set are in s1 */ if (i != 0) /* should return 0 */ goto Fail; i = strcspn (s1, ""); /* should return strlen */ if (i != strlen(s1)) goto Fail; /* strpbrk: return pointer to 1st char in set */ strPtr = strpbrk (s1, "fg:"); /* search s1 for chars not in set */ if (strPtr != &(s1 [10])) goto Fail; strPtr = strpbrk (s1, " +_-':kjihgfedcba"); /* all chars in set are in s1 */ if (strPtr != s1) /* should return ptr to start*/ goto Fail; strPtr = strpbrk (s1, ""); /* should return NULL */ if (strPtr != NULL) goto Fail; /* strrpbrk: return pointer to last char in set */ strPtr = strrpbrk (s1, "fg:"); /* search s1 for last char in set */ if (strPtr != &(s1 [22])) goto Fail; strPtr = strrpbrk (s1, " +_-':kjihgfedcba"); /* all chars in set are in s1 */ if (strPtr != &(s1[31])) goto Fail; strPtr = strrpbrk (s1, ""); /* should return ptr to end of string */ if (strPtr != NULL) goto Fail; printf ("Passed Conformance Test 15.6.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.7.0.1.CC b/Tests/Conformance/C15.7.0.1.CC new file mode 100755 index 0000000..c2b3cee --- /dev/null +++ b/Tests/Conformance/C15.7.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.7.0.1: Verification of strstr function */ #include #include main () { char string [] = " this is the source string, a source string"; char *strPtr; strPtr = strstr (string, "source string"); if (strPtr != (&( (string) [(13)] )) ) goto Fail; strPtr = strstr (string, "source string!"); if (strPtr != NULL) goto Fail; printf ("Passed Conformance Test 15.7.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.7.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.7.0.2.CC b/Tests/Conformance/C15.7.0.2.CC new file mode 100755 index 0000000..813c949 --- /dev/null +++ b/Tests/Conformance/C15.7.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 15.7.0.2: Verification of strtok function */ #include #include main () { char string [] = " this is the source string, so creative! oh, yes"; char *strPtr; /* First call to strtok pass the string to be parsed; subsequent calls */ /* just pass a NULL pointer. Separating character is space to start. */ strPtr = strtok (string, " "); if (strPtr != (&( (string) [(1)] )) ) goto Fail; strPtr = strtok (NULL, " "); if (strPtr != &string [6]) goto Fail; strPtr = strtok (NULL, " "); if (strPtr != &string [9]) goto Fail; strPtr = strtok (NULL, " "); if (strPtr != &string [13]) goto Fail; strPtr = strtok (NULL, ","); /* now change the separator set */ if (strPtr != &string [20]) goto Fail; strPtr = strtok (NULL, ","); if (strPtr != &string [27]) goto Fail; strPtr = strtok (NULL, "! &*"); /* make last calls to strtok */ if (strPtr != &string [45]) /* address of '\0' at end of string */ goto Fail; strPtr = strtok (NULL, " "); if (strPtr != NULL) goto Fail; /* Check tokenized string created by successive calls to strtok. */ strcpy(string, " this is the source string, so creative! oh, yes"); strPtr = strtok (string, " "); if (strcmp (strPtr, "this")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "is")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "the")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "source")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "string,")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "so")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "creative!")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "oh,")) goto Fail; strPtr = strtok (NULL, " "); if (strcmp (strPtr, "yes")) goto Fail; /* Check "special" cases: string is the null string, and the string */ /* contains only separator characters */ strPtr = strtok ("", " "); if (strPtr != NULL) goto Fail; strPtr = strtok ("abc", "abc"); if (strPtr != NULL) goto Fail; printf ("Passed Conformance Test 15.7.0.2\n"); return; Fail: printf ("Failed Conformance Test 15.7.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.8.0.1.CC b/Tests/Conformance/C15.8.0.1.CC new file mode 100755 index 0000000..e3b26c5 --- /dev/null +++ b/Tests/Conformance/C15.8.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.8.0.1: Verification of strtod library function */ #include #include #include main () { double d1; char string [] = " -32767 0567 -3.4e+2 "; char *strPtr; d1 = strtod (string, &strPtr); if (fabs(d1 - -32767.0) > 0.00001) goto Fail; if (strPtr != &string [8]) goto Fail; d1 = strtod (strPtr, &strPtr); if (fabs(d1 - 567.00) > 0.00001) goto Fail; if (strPtr != &string [14]) goto Fail; d1 = strtod (strPtr, &strPtr); if (fabs(d1 - (-340.00)) > 0.00001) goto Fail; if (strPtr != &string [23]) goto Fail; printf ("Passed Conformance Test 15.8.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.8.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.8.0.2.CC b/Tests/Conformance/C15.8.0.2.CC new file mode 100755 index 0000000..3cc4fdf --- /dev/null +++ b/Tests/Conformance/C15.8.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 15.8.0.2: Verification of strtol, strtoul functions */ #include #include #include #include #include void main (void) { long L1; unsigned long UL1; char string [] = " -2147483647 0xfFfFfFfF 1111 077 0xffffffffff zz "; char *strPtr; L1 = strtol (string, &strPtr, 0); if (L1 != -(0x7fFfFfff)) goto Fail; if (strPtr != &string [13]) goto Fail; UL1 = strtoul (strPtr, &strPtr, 16); /* bases 10-36 can be letters */ if (UL1 != 4294967295ul) goto Fail; if (strPtr != &string [25]) goto Fail; L1 = strtol (strPtr, &strPtr, 2); if (L1 != 15) goto Fail; if (strPtr != &string [31]) goto Fail; UL1 = strtoul (strPtr, &strPtr, 8); if (UL1 != 63) goto Fail; if (strPtr != &string [36]) goto Fail; L1 = strtol (strPtr, &strPtr, 16); if (errno != ERANGE) goto Fail; UL1 = strtoul (strPtr, &strPtr, 16); if (errno != ERANGE) goto Fail; L1 = strtol ("zz", &strPtr, 0); if (errno != ERANGE) goto Fail; UL1 = strtoul ("xx", &strPtr, 0); if (errno != ERANGE) goto Fail; printf ("Passed Conformance Test 15.8.0.2\n"); return; Fail: printf ("Failed Conformance Test 15.8.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C15.9.0.1.CC b/Tests/Conformance/C15.9.0.1.CC new file mode 100755 index 0000000..c49d888 --- /dev/null +++ b/Tests/Conformance/C15.9.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 15.9.0.1: Verification of atof, atoi, atol functions */ #include main () { double d1; int i; long L; d1 = atof ("3.5e-22"); if (d1 != 3.5e-22) goto Fail; i = atoi ("-32765"); if (i != -32765) goto Fail; L = atol ("100000"); if (L != 100000) goto Fail; printf ("Passed Conformance Test 15.9.0.1\n"); return; Fail: printf ("Failed Conformance Test 15.9.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C16.1.0.1.CC b/Tests/Conformance/C16.1.0.1.CC new file mode 100755 index 0000000..79aa086 --- /dev/null +++ b/Tests/Conformance/C16.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 16.1.0.1: Verification of memchr, memcmp, memcpy, memmove */ /* library functions */ #include #include #include main () { int i; char *rgn, *ptr1; char string [] = "Here is a string to copy to the first region!!! "; rgn = (char *) malloc (512); /* allocate some memory for test */ if (rgn == NULL) goto Fail1; /* Copy the string into the allocated area. */ ptr1 = (char *) (memcpy (rgn, string, sizeof(string)+1)); if (strcmp(ptr1,string)) goto Fail; /* Ensure memmove works for overlapping regions. */ memmove (rgn+40, rgn, sizeof(string)+1); if (strcmp(string, rgn+40)) goto Fail; /* Test memchr by searching region for characters. */ ptr1 = (char *) memchr (string, 'n', 50); if (ptr1 != string+14) goto Fail; ptr1 = (char *) (memchr (string, 'Z', 88)); if (ptr1 != NULL) goto Fail; /* Verify that the region has the correct characters. */ i = memcmp ( (char *) (rgn), (char *) (rgn + 40), 39); if (i) goto Fail; i = memcmp ( string, "Here is a string", 17); if (i <= 0) goto Fail; free (rgn); printf ("Passed Conformance Test 16.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 16.1.0.1\n"); return; Fail1: printf ("Unable to allocate memory for Conformance Test 16.1.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C16.4.0.1.CC b/Tests/Conformance/C16.4.0.1.CC new file mode 100755 index 0000000..9c791e9 --- /dev/null +++ b/Tests/Conformance/C16.4.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 16.4.0.1: Verification of memset library function */ #include #include #include main () { char *rgn, *ptr1; rgn = (char *) malloc (1024); if (rgn == NULL) goto Fail1; ptr1 = (char *) memset (rgn, 'a', 1024); if (ptr1 != rgn) goto Fail; for (; rgn != ptr1; rgn++) if (*rgn != 'a') goto Fail; free (rgn); printf ("Passed Conformance Test 16.4.0.1\n"); return; Fail: printf ("Failed Conformance Test 16.4.0.1\n"); return; Fail1: printf ("Unable to allocate memory for Conformance Test 16.4.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.10.0.1.CC b/Tests/Conformance/C17.10.0.1.CC new file mode 100755 index 0000000..1f07d57 --- /dev/null +++ b/Tests/Conformance/C17.10.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.10.0.1: Verification of fputs and puts */ #include main () { FILE *f1; int i,j; char string [255], *strPtr; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; /* Redirect standard output to a file */ stdout = freopen ("3/tmp2", "w+", stdout); if (stdout == NULL) goto Fail3; /* Write strings to output files. */ j = fputs ("this is the first string\n", f1); if (j) goto Fail; j = puts ("and this is the second string"); if (j) goto Fail; /* Check files' contents. */ rewind (f1); rewind (stdout); strPtr = fgets (string, 100, f1); if (strPtr != string) goto Fail; if (strcmp (string, "this is the first string\n")) goto Fail; strPtr = fgets (string, 100, stdout); if (strPtr != string) goto Fail; if (strcmp (string, "and this is the second string\n")) goto Fail; fclose(stdout); /* reset standard out */ i = fclose (f1); /* close the update file */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.10.0.1\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.10.0.1\n"); return; Fail1: fprintf (stderr, "Unable to open input file for Conformance Test 17.10.0.1\n"); return; Fail2: fprintf (stderr, "Unable to close input file for Conformance Test 17.10.0.1\n"); return; Fail3: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.10.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.1.CC b/Tests/Conformance/C17.11.0.1.CC new file mode 100755 index 0000000..b738756 --- /dev/null +++ b/Tests/Conformance/C17.11.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.1: Verification of fprintf, printf, sprintf: */ /* d, i format codes */ #include #include main () { FILE *f1; short i1; int i; int i2, i3; long L1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to a file */ if (stdout == NULL) goto Fail4; i1 = 32767; i2 = 0; L1 = -32767; i3 = 8; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %-0+10.8hd %0 10.*i %5.d %10.8li %#-*li M\n", i1, i3, i1, i2, L1, i3, L1); if (i != 56) goto Fail; i = printf (" %-0+10.8hd %0 10.*i %5.d %10.8li %#-*li M\n", i1, i3, i1, i2, L1, i3, L1); if (i != 56) goto Fail; i = sprintf (sstring, " %-0+10.8hd %0 10.*i %5.d %10.8li %#-*li M\n", i1, i3, i1, i2, L1, i3, L1); if (i != 56) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%55c", string); if (i != 1) goto Fail3; string [55] = '\0'; if (strcmp (string, " +000032767 000032767 -00032767\ -32767 M")) goto Fail; rewind (stdout); i = fscanf (stdout, "%55c", string); if (i != 1) goto Fail3; string [55] = '\0'; if (strcmp (string, " +000032767 000032767 -00032767\ -32767 M")) goto Fail; if (strcmp (sstring, " +000032767 000032767 -00032767\ -32767 M\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.1\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.1\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.1\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.1\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.1\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.10.CC b/Tests/Conformance/C17.11.0.10.CC new file mode 100755 index 0000000..2e7191e --- /dev/null +++ b/Tests/Conformance/C17.11.0.10.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.10: Verification of fprintf, printf, sprintf: */ /* g,G format codes */ #include main () { FILE *f1; int i; int i1, i2, i3; float fl1; double d1; extended e1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to file */ if (stdout == NULL) goto Fail4; fl1 = 9.0; d1 = -123.456e-20; e1 = 9876543210.0; i1 = 15; i2 = 8; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %+0 #5.g %-0*.*G %13.10Lg G\n", fl1, i1, i2, d1, e1); if (i != 42) goto Fail; i = printf (" %+0 #5.g %-0*.*G %13.10Lg G\n", fl1, i1, i2, d1, e1); if (i != 42) goto Fail; i = sprintf (sstring, " %+0 #5.g %-0*.*G %13.10Lg G\n", fl1, i1, i2, d1, e1); if (i != 42) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%41c", string); if (i != 1) goto Fail3; string [41] = '\0'; if (strcmp (string, " +009. -0001.23456E-18 9876543210 G")) goto Fail; rewind (stdout); i = fscanf (stdout, "%41c", string); if (i != 1) goto Fail3; string [41] = '\0'; if (strcmp (string, " +009. -0001.23456E-18 9876543210 G")) goto Fail; if (strcmp (sstring, " +009. -0001.23456E-18 9876543210 G\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.10\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.10\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.10\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.10\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.10\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.10\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.11.CC b/Tests/Conformance/C17.11.0.11.CC new file mode 100755 index 0000000..356eee6 --- /dev/null +++ b/Tests/Conformance/C17.11.0.11.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.11: Verification of fprintf, printf, sprintf: */ /* n and % format codes */ #include main () { FILE *f1; int i, i1, i2; short sh; long l1; extended e1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to file */ if (stdout == NULL) goto Fail4; e1 = 123.456e-205; i1 = 6; i2 = 16; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, "%% %hn %0+*.*le %s %% %ln N\n", &sh, i1, i2, e1, "a string", &l1); if (i != 48) goto Fail; if ((sh != 3) || (l1 != 44)) /* check return values for n format */ goto Fail; i = printf ("%% %hn %0+*.*le %s %% %ln N\n", &sh, i1, i2, e1, "a string", &l1); if (i != 48) goto Fail; if ((sh != 3) || (l1 != 44)) /* check return values for n format */ goto Fail; i = sprintf (sstring, "%% %hn %0+*.*le %s %% %ln N\n", &sh, i1, i2, e1, "a string", &l1); if (i != 48) goto Fail; if ((sh != 3) || (l1 != 44)) /* check return values for n format */ goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%47c", string); if (i != 1) goto Fail3; string [47] = '\0'; if (strcmp (string, "% +1.2345599999999999e-203 a string % N")) goto Fail; rewind (stdout); i = fscanf (stdout, "%47c", string); if (i != 1) goto Fail3; string [47] = '\0'; if (strcmp (string, "% +1.2345599999999999e-203 a string % N")) goto Fail; if (strcmp (sstring, "% +1.2345599999999999e-203 a string % N\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.11\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.11\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.11\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.11\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.11\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.11\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.2.CC b/Tests/Conformance/C17.11.0.2.CC new file mode 100755 index 0000000..bb3f64c --- /dev/null +++ b/Tests/Conformance/C17.11.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.2: Verification of fprintf, sprintf, printf: */ /* u format code */ #include main () { FILE *f1; int i, i1, i2; unsigned int ui1, ui2; unsigned long ul1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to a file */ if (stdout == NULL) goto Fail4; ui1 = 65535; ui2 = 0; ul1 = 4294967295u; i1 = 12; i2 = 16; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %-11.10hu %# +07.4lu %.0u %-*.*lu A\n", ui1, (long) ui1, ui2, i1, i2, ul1); if (i != 45) goto Fail; i = printf (" %-11.10hu %# +07.4lu %.0u %-*.*lu A\n", ui1, (long) ui1, ui2, i1, i2, ul1); if (i != 45) goto Fail; i = sprintf (sstring, " %-11.10hu %# +07.4lu %.0u %-*.*lu A\n", ui1, (long) ui1, ui2, i1, i2, ul1); if (i != 45) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%44c", string); if (i != 1) goto Fail3; string [44] = '\0'; i = fprintf (f1, " %-11.10hu %# +07.4lu %.0u %-*.*lu A\n", ui1, (long) ui1, ui2, i1, i2, ul1); if (strcmp (string, " 0000065535 +065535 0000004294967295 A")) goto Fail; rewind (stdout); i = fscanf (stdout, "%44c", string); if (i != 1) goto Fail3; string [44] = '\0'; if (strcmp (string, " 0000065535 +065535 0000004294967295 A")) goto Fail; if (strcmp (sstring, " 0000065535 +065535 0000004294967295 A\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.2\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.2\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.2\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.2\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.2\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.3.CC b/Tests/Conformance/C17.11.0.3.CC new file mode 100755 index 0000000..070d009 --- /dev/null +++ b/Tests/Conformance/C17.11.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.3: Verification of fprintf, printf, sprintf: */ /* o format code */ #include main () { FILE *f1; int i, i1, i2; unsigned int ui1, ui2; unsigned long ul1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to a file */ if (stdout == NULL) goto Fail4; ui1 = 65535; ui2 = 0; ul1 = 4294967295u; i1 = 6; i2 = 9; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %-+ #10.5ho %#0*.*o %o %-12lo B\n", ui1, i1, i2, ui1, ui2, ul1); if (i != 43) goto Fail; i = printf (" %-+ #10.5ho %#0*.*o %o %-12lo B\n", ui1, i1, i2, ui1, ui2, ul1); if (i != 43) goto Fail; i = sprintf (sstring, " %-+ #10.5ho %#0*.*o %o %-12lo B\n", ui1, i1, i2, ui1, ui2, ul1); if (i != 43) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%42c", string); if (i != 1) goto Fail3; string [42] = '\0'; if (strcmp (string, " 0177777 000177777 0 37777777777 B")) goto Fail; rewind (stdout); i = fscanf (stdout, "%42c", string); if (i != 1) goto Fail3; string [42] = '\0'; if (strcmp (string, " 0177777 000177777 0 37777777777 B")) goto Fail; if (strcmp (sstring, " 0177777 000177777 0 37777777777 B\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.3\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.3\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.3\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.3\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.3\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.3\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.4.CC b/Tests/Conformance/C17.11.0.4.CC new file mode 100755 index 0000000..528dc75 --- /dev/null +++ b/Tests/Conformance/C17.11.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.4: Verification of fprintf, printf, sprintf: */ /* x,X format codes */ #include main () { FILE *f1; int i, i1, i2; unsigned int ui1, ui2; unsigned long ul1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to a file */ if (stdout == NULL) goto Fail4; ui1 = 65535u; ui2 = 0; ul1 = 4294967295u; i1 = 12; i2 = 10; /* Write formatted output as string to the output file. */ i = fprintf (f1, " %#+ -10.10x %#+ 09.8X %.0x %+ *.*lx C\n", ui1, ui1, ui2, i1, i2, ul1); if (i != 45) goto Fail; i = printf (" %#+ -10.10x %#+ 09.8X %.0x %+ *.*lx C\n", ui1, ui1, ui2, i1, i2, ul1); if (i != 45) goto Fail; i = sprintf (sstring, " %#+ -10.10x %#+ 09.8X %.0x %+ *.*lx C\n", ui1, ui1, ui2, i1, i2, ul1); if (i != 45) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%44c", string); if (i != 1) goto Fail3; string [44] = '\0'; if (strcmp (string, " 0x000000ffff 0X0000FFFF 00ffffffff C")) goto Fail; rewind (stdout); i = fscanf (stdout, "%44c", string); if (i != 1) goto Fail3; string [44] = '\0'; if (strcmp (string, " 0x000000ffff 0X0000FFFF 00ffffffff C")) goto Fail; if (strcmp (sstring, " 0x000000ffff 0X0000FFFF 00ffffffff C\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.4\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.4\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.4\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.4\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.4\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.4\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.5.CC b/Tests/Conformance/C17.11.0.5.CC new file mode 100755 index 0000000..de18661 --- /dev/null +++ b/Tests/Conformance/C17.11.0.5.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.5: Verification of fprintf, printf, sprintf: */ /* c format code */ #include main () { FILE *f1; int i, i1, i2; unsigned int ui1, ui2; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to a file */ if (stdout == NULL) goto Fail4; ui1 = 'a'; ui2 = 'b'; i1 = 3; i2 = 2; /* Write formatted output as string to the output file. */ i = fprintf (f1, " %#+ -010.10c %05.7hc %.6lc %+ *.*lc D\n", ui1, ui1, ui2, i1, i2, 'd'); if (i != 30) goto Fail; i = printf (" %#+ -010.10c %05.7hc %.6lc %+ *.*lc D\n", ui1, ui1, ui2, i1, i2, 'd'); if (i != 30) goto Fail; i = sprintf (sstring, " %#+ -010.10c %05.7hc %.6lc %+ *.*lc D\n", ui1, ui1, ui2, i1, i2, 'd'); if (i != 30) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%29c", string); if (i != 1) goto Fail3; string [29] = '\0'; if (strcmp (string, " a a b d D")) goto Fail; rewind (stdout); i = fscanf (stdout, "%29c", string); if (i != 1) goto Fail3; string [29] = '\0'; if (strcmp (string, " a a b d D")) goto Fail; if (strcmp (sstring, " a a b d D\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.5\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.5\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.5\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.5\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.5\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.5\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.6.CC b/Tests/Conformance/C17.11.0.6.CC new file mode 100755 index 0000000..feac8b3 --- /dev/null +++ b/Tests/Conformance/C17.11.0.6.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.6: Verification of fprintf, printf, sprintf: */ /* s format code */ #include main () { FILE *f1; int i, j, k; char sstring [80]; char string [80], arg1 [] = "first string argument", arg2 [] = "second string argument "; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to a file */ if (stdout == NULL) goto Fail4; j = 15; k = 30; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %#+ -10.10s %015.7hs %*.*s %s E\n", arg1, arg1, j, k, arg2, "very short string"); if (i != 77) goto Fail; i = printf (" %#+ -10.10s %015.7hs %*.*s %s E\n", arg1, arg1, j, k, arg2, "very short string"); if (i != 77) goto Fail; i = sprintf (sstring, " %#+ -10.10s %015.7hs %*.*s %s E\n", arg1, arg1, j, k, arg2, "very short string"); if (i != 77) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%76c", string); if (i != 1) goto Fail3; string [76] = '\0'; if (strcmp (string, " first stri first s second string argument \ very short string E")) goto Fail; rewind (stdout); i = fscanf (stdout, "%76c", string); if (i != 1) goto Fail3; string [76] = '\0'; if (strcmp (string, " first stri first s second string argument \ very short string E")) goto Fail; if (strcmp (sstring, " first stri first s second string argument \ very short string E\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.6\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.6\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.6\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.6\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.6\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.6\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.7.CC b/Tests/Conformance/C17.11.0.7.CC new file mode 100755 index 0000000..2b02f15 --- /dev/null +++ b/Tests/Conformance/C17.11.0.7.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.7: Verification of fprintf, printf, sprintf: */ /* p format code */ #include main () { FILE *f1; int i, j, k; char sstring [80]; char string [80], arg1 [] = "\pfirst string argument", arg2 [] = "\psecond string argument "; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to file */ if (stdout == NULL) goto Fail4; j = 15; k = 30; /* Write formatted output as string to the output file. */ i = fprintf (f1, " %#+ -10.10b %015.7hb %*.*b %b E\n", arg1, arg1, j, k, arg2, "\pvery short string"); if (i != 77) goto Fail; i = printf (" %#+ -10.10b %015.7hb %*.*b %b E\n", arg1, arg1, j, k, arg2, "\pvery short string"); if (i != 77) goto Fail; i = sprintf (sstring, " %#+ -10.10b %015.7hb %*.*b %b E\n", arg1, arg1, j, k, arg2, "\pvery short string"); if (i != 77) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%76c", string); if (i != 1) goto Fail3; string [76] = '\0'; if (strcmp (string, " first stri first s second string argument \ very short string E")) goto Fail; rewind (stdout); i = fscanf (stdout, "%76c", string); if (i != 1) goto Fail3; string [76] = '\0'; if (strcmp (string, " first stri first s second string argument \ very short string E")) goto Fail; if (strcmp (sstring, " first stri first s second string argument \ very short string E\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.7\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.7\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.7\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.7\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.7\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.7\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.8.CC b/Tests/Conformance/C17.11.0.8.CC new file mode 100755 index 0000000..cb0493a --- /dev/null +++ b/Tests/Conformance/C17.11.0.8.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.8: Verification of fprintf, printf, sprintf: */ /* f format code */ #include main () { FILE *f1; int i; int i2, i3; float fl1; double d1; extended e1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to file */ if (stdout == NULL) goto Fail4; fl1 = 45.0; d1 = 123.456e-2; e1 = 99.999; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %# +012.7f %+-8.f %# 011lf T\n", d1, fl1, e1); if (i != 40) goto Fail; i = printf (" %# +012.7f %+-8.f %# 011lf T\n", d1, fl1, e1); if (i != 40) goto Fail; i = sprintf (sstring, " %# +012.7f %+-8.f %# 011lf T\n", d1, fl1, e1); if (i != 40) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%39c", string); if (i != 1) goto Fail3; string [39] = '\0'; if (strcmp (string, " +001.2345600 +45 099.999000 T")) goto Fail; rewind (stdout); i = fscanf (stdout, "%39c", string); if (i != 1) goto Fail3; string [39] = '\0'; if (strcmp (string, " +001.2345600 +45 099.999000 T")) goto Fail; if (strcmp (sstring, " +001.2345600 +45 099.999000 T\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.8\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.8\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.8\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.8\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.8\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.8\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.11.0.9.CC b/Tests/Conformance/C17.11.0.9.CC new file mode 100755 index 0000000..c85210a --- /dev/null +++ b/Tests/Conformance/C17.11.0.9.CC @@ -0,0 +1 @@ +/* Conformance Test 17.11.0.9: Verification of fprintf, printf, sprintf: */ /* e, E format codes */ #include main () { FILE *f1; int i; int i1, i2, i3; float fl1; double d1; extended e1; char string [80], sstring [80]; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; stdout = freopen ("3/tmp2", "w+", stdout); /* redirect stdout to file */ if (stdout == NULL) goto Fail4; fl1 = 5.0; d1 = -4.7; e1 = 123.456e-205; i1 = 6; i2 = 16; /* Write formatted output as string to the output files and sstring. */ i = fprintf (f1, " %0+*.*le %- 15E %#0 .e E\n", i1, i2, e1, d1, fl1); if (i != 54) goto Fail; i = printf (" %0+*.*le %- 15E %#0 .e E\n", i1, i2, e1, d1, fl1); if (i != 54) goto Fail; i = sprintf (sstring, " %0+*.*le %- 15E %#0 .e E\n", i1, i2, e1, d1, fl1); if (i != 54) goto Fail; /* Check the string written. */ rewind (f1); i = fscanf (f1, "%53c", string); if (i != 1) goto Fail3; string [53] = '\0'; if (strcmp (string, " +1.2345599999999999e-203 -4.700000E+00 5e+00 E")) goto Fail; rewind (stdout); i = fscanf (stdout, "%53c", string); if (i != 1) goto Fail3; string [53] = '\0'; if (strcmp (string, " +1.2345599999999999e-203 -4.700000E+00 5e+00 E")) goto Fail; if (strcmp (sstring, " +1.2345599999999999e-203 -4.700000E+00 5e+00 E\n")) goto Fail; fclose(stdout); /* redirect stdout to screen */ i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.11.0.9\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.11.0.9\n"); return; Fail1: fprintf (stderr, "Unable to open output file for Conformance Test 17.11.0.9\n"); return; Fail2: fprintf (stderr, "Unable to close output file for Conformance Test 17.11.0.9\n"); return; Fail3: fprintf (stderr, "Unable to read output file for Conformance Test 17.11.0.9\n"); return; Fail4: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.11.0.9\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.13.0.1.CC b/Tests/Conformance/C17.13.0.1.CC new file mode 100755 index 0000000..3f8d119 --- /dev/null +++ b/Tests/Conformance/C17.13.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.13.0.1: Verification of fread and fwrite */ #include #include struct S { int i; float f; char c; }; main () { struct S s [3] = { 1, 1.0, 'a', 2, 2.0, 'b', 3, 3.0, 'c' }; struct S buff [3]; FILE *f = fopen ("3/tmp", "w+b"); int i; /* Write the elements to the file. */ if (f == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f); if (i != 3) goto Fail; /* Read the elements from the file. */ rewind (f); i = fread ((void *) buff, sizeof (struct S), 3, f); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((fabs(s [0].f - 1.0) > 0.00001) || (fabs(s [1].f - 2.0) > 0.00001) || (fabs(s [2].f - 3.0) > 0.00001)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; /* Ensure that a count or element_size of 0 causes no chars to be written. */ i = fwrite ((void *) s, sizeof (struct S), 0, f); if (i != 0) goto Fail; i = fwrite ((void *) s, 0, 2, f); if (i != 2) goto Fail; rewind (f); i = fread ((void *) s, sizeof (struct S), 0, f); if (i != 0) goto Fail; i = fread ((void *) s, 0, 2, f); if (i != 0) goto Fail; i = fclose (f); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.13.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.13.0.1\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.13.0.1\n"); return; Fail2: printf ("Unable to close output file for Conformance Test 17.13.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.14.0.1.CC b/Tests/Conformance/C17.14.0.1.CC new file mode 100755 index 0000000..b3c5bb3 --- /dev/null +++ b/Tests/Conformance/C17.14.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.14.0.1: Verification of ferror and clearerr */ #include struct S { int i; float f; char c; }; main () { struct S s [3] = { 1, 1.0, 'a', 2, 2.0, 'b', 3, 3.0, 'c' }; struct S buff [3]; FILE *f = fopen ("3/tmp", "w+b"); int i; /* Write the elements to the file. */ if (f == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f); if (i != 3) goto Fail; /* Cause an error to occur. */ rewind (f); i = fread ((void *) buff, sizeof (struct S), 5, f); if (i != 3) goto Fail; i = ferror (f); if (i != 0) goto Fail; i = feof (f); if (i == 0) goto Fail; /* clear the error */ clearerr (f); i = feof (f); if (i != 0) goto Fail; i = fclose (f); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.14.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.14.0.1\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.14.0.1\n"); return; Fail2: printf ("Unable to close output file for Conformance Test 17.14.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.15.0.1.CC b/Tests/Conformance/C17.15.0.1.CC new file mode 100755 index 0000000..197986f --- /dev/null +++ b/Tests/Conformance/C17.15.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.15.0.1: Verification of remove and rename */ #include struct S { int i; float f; char c; }; main () { struct S s [3] = { 1, 1.0, 'a', 2, 2.0, 'b', 3, 3.0, 'c' }; struct S buff [3]; FILE *f = fopen ("3/tmp", "wb"); int i; /* Write the elements to the file. */ if (f == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f); if (i != 3) goto Fail; i = fclose (f); /* close the file */ if (i == EOF) goto Fail2; /* Rename and then delete the file. */ i = remove ("3/temp"); i = rename ("3/tmp", "3/temp"); if (i) goto Fail; i = remove ("3/temp"); if (i) goto Fail; printf ("Passed Conformance Test 17.15.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.15.0.1\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.15.0.1\n"); return; Fail2: printf ("Unable to close output file for Conformance Test 17.15.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.16.0.1.CC b/Tests/Conformance/C17.16.0.1.CC new file mode 100755 index 0000000..d4143d2 --- /dev/null +++ b/Tests/Conformance/C17.16.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.16.0.1: Verification of tmpfile function */ #include struct S { int i; float f; char c; }; main () { struct S s [3] = { 1, 1.0, 'a', 2, 2.0, 'b', 3, 3.0, 'c' }; struct S buff [3]; FILE *f1, *f2, *f3; int i; /* Create 3 temp files and write the elements to the files. */ f1 = tmpfile (); if (f1 == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f1); if (i != 3) goto Fail; f2 = tmpfile (); if (f2 == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f2); if (i != 3) goto Fail; f3 = tmpfile (); if (f3 == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f3); if (i != 3) goto Fail; /* Read the elements from the files. */ rewind (f1); i = fread ((void *) buff, sizeof (struct S), 3, f1); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((s [0].f != 1.0) || (s [1].f != 2.0) || (s [2].f != 3.0)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; rewind (f2); i = fread ((void *) buff, sizeof (struct S), 3, f2); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((s [0].f != 1.0) || (s [1].f != 2.0) || (s [2].f != 3.0)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; rewind (f2); i = fread ((void *) buff, sizeof (struct S), 3, f2); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((s [0].f != 1.0) || (s [1].f != 2.0) || (s [2].f != 3.0)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; i = fclose (f1); /* close the files and quit */ if (i == EOF) goto Fail2; i = fclose (f2); if (i == EOF) goto Fail2; i = fclose (f3); if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.16.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.16.0.1\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.16.0.1\n"); return; Fail2: printf ("Unable to close output file for Conformance Test 17.16.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.5.0.1.CC b/Tests/Conformance/C17.5.0.1.CC new file mode 100755 index 0000000..4b6be47 --- /dev/null +++ b/Tests/Conformance/C17.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.5.0.1: Verification of fseek function */ #include main () { FILE *f1; /* file pointer */ int i, j, k, m; f1 = fopen ("3/tmp", "w+b"); /* create binary file to work on */ if (f1 == NULL) goto Fail1; for (i = 0; i < 100; i++) /* write 100 integers to the file */ { j = fprintf (f1, "%2d ", i); if (j == EOF) goto Fail2; } i = fseek (f1, 50, SEEK_END); /* extend file by extra 50 bytes */ if (i) goto Fail; rewind (f1); /* position at beginning of file */ i = 0; while ((j = fgetc (f1)) != EOF) i += 1; if (! (j = feof (f1)) ) goto Fail3; if (i != 450) /* check size of file in bytes */ goto Fail; /* Test seek from beginning of file. */ for (k = 0, i = 0; i < 100; i++) { j = fseek (f1, k, SEEK_SET); if (j) goto Fail; j = fscanf (f1, "%d", &m); if (j == EOF) goto Fail3; if (m != i) goto Fail; k += 4; } /* Test seek from end of file. */ j = fseek (f1, -54, SEEK_END); /* start 54 bytes from end of file */ if (j) goto Fail; for (k = -54, i = 99; i > 0; i--) { j = fscanf (f1, "%d", &m); if (j == EOF) goto Fail3; if (m != i) goto Fail; k -= 4; j = fseek (f1, k, SEEK_END); if (j) goto Fail; } /* Test seek from current position in file. */ j = fseek (f1, 12, SEEK_CUR); if (j) goto Fail; j = fscanf (f1, "%d", &m); if (j == EOF) goto Fail3; if (m != 3) goto Fail; j = fseek (f1, 12, SEEK_CUR); if (j) goto Fail; j = fscanf (f1, "%d", &m); if (j == EOF) goto Fail3; if (m != 7) goto Fail; /* Close the file and quit. */ j = fclose (f1); if (j == EOF) goto Fail4; printf ("Passed Conformance Test 17.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.5.0.1\n"); return; Fail1: printf ("Could not open tmp file for Conformance Test 17.5.0.1\n"); return; Fail2: printf ("Could not write to file for Conformance Test 17.5.0.1\n"); return; Fail3: printf ("Error while reading file for Conformance Test 17.5.0.1\n"); return; Fail4: printf ("Could not close file for Conformance Test 17.5.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.5.0.2.CC b/Tests/Conformance/C17.5.0.2.CC new file mode 100755 index 0000000..4f88866 --- /dev/null +++ b/Tests/Conformance/C17.5.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 17.5.0.2: Verification of fseek, rewind, and ftell */ /* functions for text files */ #include main () { FILE *f1; /* file pointer */ int i, j, m; long L1; char s [254], ch1; char ch [254] = "a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z." "a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z." "a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z." "a.b.c.d.e.f.g.h.i.j.k.l.m.n.o.p.q.r.s.t.u.v.w.x.y.z." "A.B.C.D.E.F.G.H.I.J.K.L.M.N.O.P.Q.R.S.T.U.V."; f1 = fopen ("14:tmp", "w+"); /* create temporary file to work on */ if (f1 == NULL) goto Fail1; for (i = 0; i < 100; i++) /* write 100 lines to the file */ { j = fprintf (f1, "%s\n", ch); if (j == EOF) goto Fail2; } /* Test seek from beginning of file. */ j = fseek (f1, 0L, SEEK_SET); if (j) goto Fail; for (i = 0; i < 100; i++) { j = fscanf (f1, "%s", s); if (j == EOF) goto Fail3; if (strcmp (s, ch)) goto Fail; } /* Test seek from end of file. */ j = fseek (f1, 0L, SEEK_END); if (j) goto Fail; j = fscanf (f1, "%c", &m); if (j != EOF) goto Fail3; /* Test ftell function. */ L1 = ftell (f1); if (L1 != 25300) goto Fail; rewind (f1); L1 = ftell (f1); if (L1 != 0) goto Fail; ch1 = fgetc (f1); if (ch1 == EOF) goto Fail3; if (ch1 != 'a') goto Fail; ch1 = fgetc (f1); if (ch1 == EOF) goto Fail3; if (ch1 != '.') goto Fail; L1 = ftell (f1); if (L1 != 2) goto Fail; ch1 = fgetc (f1); if (ch1 == EOF) goto Fail3; if (ch1 != 'b') goto Fail; ch1 = fgetc (f1); if (ch1 == EOF) goto Fail3; if (ch1 != '.') goto Fail; ch1 = fgetc (f1); if (ch1 == EOF) goto Fail3; if (ch1 != 'c') goto Fail; j = fseek (f1, L1, SEEK_SET); /* verify that ftell-position works */ if (j) goto Fail; ch1 = fgetc (f1); if (ch1 == EOF) goto Fail3; if (ch1 != 'b') goto Fail; /* Close the file and quit. */ j = fclose (f1); if (j == EOF) goto Fail4; printf ("Passed Conformance Test 17.5.0.2\n"); return; Fail: printf ("Failed Conformance Test 17.5.0.2\n"); return; Fail1: printf ("Could not open tmp file for Conformance Test 17.5.0.2\n"); return; Fail2: printf ("Could not write to file for Conformance Test 17.5.0.2\n"); return; Fail3: printf ("Error while reading file for Conformance Test 17.5.0.2\n"); return; Fail4: printf ("Could not close file for Conformance Test 17.5.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.6.0.1.CC b/Tests/Conformance/C17.6.0.1.CC new file mode 100755 index 0000000..d3cd835 --- /dev/null +++ b/Tests/Conformance/C17.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.6.0.1: Verification of fgetc, getc, and ungetc with */ /* a text stream */ #include main () { FILE *f1; int i, j; char ch; f1 = fopen ("3/tmp", "w+"); /* create text file to work on */ if (f1 == NULL) goto Fail1; for (ch = 'a', i = 0; i < 26; i++) { j = fputc (ch, f1); if ((char) j != ch) goto Fail2; ch++; } j = fputc ('\r', f1); /* text files end with return */ if (j != '\r') goto Fail2; rewind (f1); /* check file contents with fgetc */ for (ch = 'a', i = 0; i < 26; i++) { j = fgetc (f1); if ( (char) j != ch++ ) goto Fail; } i = ungetc ('F', f1); /* test ungetc */ if (i != 'F') goto Fail; i = fgetc (f1); if (i != 'F') goto Fail; i = fgetc (f1); if (i != '\n') goto Fail; i = fgetc (f1); if (! (feof (f1)) ) /* ensure end-of-file reached */ goto Fail; j = ungetc (i, f1); /* not an error to try to push */ if (j != EOF) /* back EOF */ goto Fail; j = fseek (f1, 0L, SEEK_SET); /* test getc with temp file */ if (j) goto Fail3; j = ungetc (i, f1); /* ungetc should return an error */ if (j != EOF) /* after seeking on the file */ goto Fail; /* before reading */ for (ch = 'a', i = 0; i < 26; i++) { j = getc (f1); if ( (char) j != ch++ ) goto Fail; } i = ungetc ('L', f1); /* test ungetc */ if (i != 'L') goto Fail; i = fgetc (f1); if (i != 'L') goto Fail; i = getc (f1); if (i != '\n') goto Fail; i = getc (f1); if (! (feof (f1)) ) /* ensure end-of-file reached */ goto Fail; j = ungetc (i, f1); /* not an error to try to push */ if (j != EOF) /* back EOF */ goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail4; printf ("Passed Conformance Test 17.6.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.6.0.1\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.6.0.1\n"); return; Fail2: printf ("Unable to write to temp file for Conformance Test 17.6.0.1\n"); return; Fail3: printf ("Unable to seek to temp file for Conformance Test 17.6.0.1\n"); return; Fail4: printf ("Unable to close temp file for Conformance Test 17.6.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.6.0.2.CC b/Tests/Conformance/C17.6.0.2.CC new file mode 100755 index 0000000..998c07b --- /dev/null +++ b/Tests/Conformance/C17.6.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 17.6.0.2: Verification of fgetc, getc, and ungetc with */ /* a binary stream */ #include main () { FILE *f1; int i, j; char ch; f1 = fopen ("3/tmp", "w+b"); /* create binary file to work on */ if (f1 == NULL) goto Fail1; for (ch = 'a', i = 0; i < 26; i++) { j = fputc (ch, f1); if ((char) j != ch) goto Fail2; ch++; } rewind (f1); /* check file contents with fgetc */ ch = 'a'; while ((i = fgetc (f1)) != EOF) if ( (char) i != ch++ ) goto Fail; if (! (feof (f1)) ) /* ensure end-of-file reached */ goto Fail; j = ungetc (i, f1); /* not an error to try to push */ if (j != EOF) /* back EOF */ goto Fail; j = fseek (f1, 0L, SEEK_SET); /* test getc with temp file */ if (j) goto Fail3; j = ungetc (i, f1); /* ungetc should return an error */ if (j != EOF) /* after seeking on the file */ goto Fail; /* before reading */ ch = 'a'; while ((i = getc (f1)) != EOF) if ( (char) i != ch++ ) goto Fail; if (! (feof (f1)) ) /* ensure end-of-file reached */ goto Fail; j = ungetc (i, f1); /* not an error to try to push */ if (j != EOF) /* back EOF */ goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail4; printf ("Passed Conformance Test 17.6.0.2\n"); return; Fail: printf ("Failed Conformance Test 17.6.0.2\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.6.0.2\n"); return; Fail2: printf ("Unable to write to temp file for Conformance Test 17.6.0.2\n"); return; Fail3: printf ("Unable to seek to temp file for Conformance Test 17.6.0.2\n"); return; Fail4: printf ("Unable to close temp file for Conformance Test 17.6.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.7.0.1.CC b/Tests/Conformance/C17.7.0.1.CC new file mode 100755 index 0000000..441016f --- /dev/null +++ b/Tests/Conformance/C17.7.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.7.0.1: Verification of fgets function, text stream */ #include main () { FILE *f1; int i; char string [80] = ""; /* initialize input string to null string */ char *strPtr; f1 = fopen ("3/tmp", "w+"); /* create text file to work on */ if (f1 == NULL) goto Fail1; i = fputs ("Every good boy deserves favor\n", f1); if (i) goto Fail2; rewind (f1); /* test reading until '\n' seen */ strPtr = fgets (string, 100, f1); if (strPtr == NULL) goto Fail; if (strcmp ("Every good boy deserves favor\n", string)) goto Fail; fgetc(f1); /* force an EOF condition */ strPtr = fgets (string, 100, f1); /* test reading with EOF seen before */ if (strPtr != NULL) /* any other characters */ goto Fail; if (! (feof (f1)) ) goto Fail; if (strcmp ("Every good boy deserves favor\n", string)) goto Fail; rewind (f1); /* test reading until n-1 chars seen */ strPtr = fgets (string, 15, f1); if (strPtr == NULL) goto Fail; if (strcmp ("Every good boy", string)) goto Fail; strPtr = fgets (string, 17, f1); /* ensure fgets moves internal file */ if (strPtr == NULL) /* pointer */ goto Fail; if (strcmp (" deserves favor\n", string)) goto Fail; fgetc(f1); /* force an EOF condition */ strPtr = fgets (string, 100, f1); /* test reading with EOF seen before */ if (strPtr != NULL) /* any other characters */ goto Fail; if (! (feof (f1)) ) goto Fail; if (strcmp (" deserves favor\n", string)) goto Fail; i = fclose (f1); /* close file and quit */ if (i) goto Fail3; printf ("Passed Conformance Test 17.7.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.7.0.1\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.7.0.1\n"); return; Fail2: printf ("Unable to write to temp file for Conformance Test 17.7.0.1\n"); return; Fail3: printf ("Unable to close temp file for Conformance Test 17.7.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.7.0.2.CC b/Tests/Conformance/C17.7.0.2.CC new file mode 100755 index 0000000..e7280e6 --- /dev/null +++ b/Tests/Conformance/C17.7.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 17.7.0.2: Verification of fgets function, binary stream */ #include main () { FILE *f1; int i; char string [80] = ""; /* initialize input string to null string */ char *strPtr; f1 = fopen ("3/tmp", "w+b"); /* create binary file to work on */ if (f1 == NULL) goto Fail1; i = fputs ("Every good boy deserves favor\n", f1); if (i) goto Fail2; rewind (f1); /* test reading until '\n' seen */ strPtr = fgets (string, 100, f1); if (strPtr == NULL) goto Fail; if (strcmp ("Every good boy deserves favor\n", string)) goto Fail; fgetc(f1); /* force an EOF condition */ strPtr = fgets (string, 100, f1); /* test reading with EOF seen before */ if (strPtr != NULL) /* any other characters */ goto Fail; if (! (feof (f1)) ) goto Fail; if (strcmp ("Every good boy deserves favor\n", string)) goto Fail; rewind (f1); /* test reading until n-1 chars seen */ strPtr = fgets (string, 15, f1); if (strPtr == NULL) goto Fail; if (strcmp ("Every good boy", string)) goto Fail; strPtr = fgets (string, 17, f1); /* ensure fgets moves internal file */ if (strPtr == NULL) /* pointer */ goto Fail; if (strcmp (" deserves favor\n", string)) goto Fail; fgetc(f1); /* force an EOF condition */ strPtr = fgets (string, 100, f1); /* test reading with EOF seen before */ if (strPtr != NULL) /* any other characters */ goto Fail; if (! (feof (f1)) ) goto Fail; if (strcmp (" deserves favor\n", string)) goto Fail; i = fclose (f1); /* close file and quit */ if (i) goto Fail3; printf ("Passed Conformance Test 17.7.0.2\n"); return; Fail: printf ("Failed Conformance Test 17.7.0.2\n"); return; Fail1: printf ("Unable to open temp file for Conformance Test 17.7.0.2\n"); return; Fail2: printf ("Unable to write to temp file for Conformance Test 17.7.0.2\n"); return; Fail3: printf ("Unable to close temp file for Conformance Test 17.7.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.1.CC b/Tests/Conformance/C17.8.0.1.CC new file mode 100755 index 0000000..835d6a0 --- /dev/null +++ b/Tests/Conformance/C17.8.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.1: Verification of fscanf, d format code */ #include main () { FILE *f1; short i1; int i; int i2, i3; long L1; char ch; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " +327678 - -002147483647A 327677-22 123*\r"); rewind(f1); i1 = 0; /* test format string of no */ i = fscanf (f1, "%*05hd8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (i1 != 0) /* after 5 digits read */ goto Fail; i2 = 15; /* test "plain vanilla" fmt */ i = fscanf (f1, "%d", &i2); /* string; data contains */ if (i != 1) /* a single minus sign */ goto Fail; if (i2 != 0) goto Fail; L1 = 0; /* test format string of */ i = fscanf (f1, "%12ldA", &L1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character A must appear*/ if (L1 != -2147483647) /* after digits read */ goto Fail; L1 = 0; /* test format string of */ i = fscanf (f1, "%6ld%d", &L1, &i2); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((L1 != 327677) || (i2 != -22)) /* for integer */ goto Fail; i3 = 4; /* test format string of */ i = fscanf (f1, "%4hd", &i3); /* max. field width of 4, */ if (i != 1) /* short variable expectd.*/ goto Fail; /* * appears in input as */ if (i3 != 123) /* 4th char. */ goto Fail; i = fscanf (f1, "%c", &ch); /* Ensure offending * has */ if (i != 1) /* been left in input. */ goto Fail; if (ch != '*') goto Fail; i = fscanf (f1, "%c", &ch); /* Ensure fscanf returns EOF*/ if (i != 1) /* when EOF encountered. */ goto Fail; if (ch != '\r') goto Fail; fgetc(f1); i = fscanf (f1, "%c", &ch); if (i != EOF) goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.1\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.1\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.1\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.10.CC b/Tests/Conformance/C17.8.0.10.CC new file mode 100755 index 0000000..6b7756c --- /dev/null +++ b/Tests/Conformance/C17.8.0.10.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.10: Verification of sscanf, u format code */ #include main () { char string [] = " 327678 D 4294967295m 32767722 "; int i; unsigned short us1; unsigned int ui1; unsigned long ul1; ui1 = 2; /* test format string of no */ i = sscanf (string, "%*05hu8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (ui1 != 2) /* after 5 digits read */ goto Fail; i = sscanf (&string [8], "%u", &ui1); /* test "plain vanilla" fmt */ if (i != 0) /* string; data contains */ goto Fail; /* the character 'D' */ ul1 = 0; /* test fmt string of max */ i = sscanf (&string [11], " D %12ldm", &ul1); /* field width of 12, */ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test fmt string of max */ i = sscanf (&string [27], "%6lu%u", &ul1, &ui1); /* field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 327677) || (ui1 != 22)) /* for integer */ goto Fail; printf ("Passed Conformance Test 17.8.0.10\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.10\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.11.CC b/Tests/Conformance/C17.8.0.11.CC new file mode 100755 index 0000000..777a62b --- /dev/null +++ b/Tests/Conformance/C17.8.0.11.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.11: Verification of sscanf, o format code */ #include main () { char string [] = " 777778 D 37777777777m 117777526 "; int i; unsigned short us1; unsigned int ui1; unsigned long ul1; us1 = 2; /* test format string of no */ i = sscanf (string, "%*05ho8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (us1 != 2) /* after 5 digits read */ goto Fail; i = sscanf (&string [9], "%o", &ui1); /* test "plain vanilla" fmt */ if (i != 0) /* string; data contains */ goto Fail; /* the character 'D' */ ul1 = 0; /* test fmt string of max */ i = sscanf (&string [11], "D %12lom", &ul1); /* field width of 12, */ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test fmt string of max */ i = sscanf (&string [31], "%7lo%o", &ul1, &ui1); /* field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 327677) || (ui1 != 22)) /* for integer */ goto Fail; printf ("Passed Conformance Test 17.8.0.11\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.11\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.12.CC b/Tests/Conformance/C17.8.0.12.CC new file mode 100755 index 0000000..368d325 --- /dev/null +++ b/Tests/Conformance/C17.8.0.12.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.12: Verification of sscanf, x,X format codes */ #include main () { char string [] = " 327678 0x D 0xFFFFFFFFm 0x7fEd0X10 "; int i; unsigned short us1; unsigned int ui1; unsigned long ul1; us1 = 2; /* test format string of no */ i = sscanf (string, "%*05hx8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (us1 != 2) /* after 5 digits read */ goto Fail; i = sscanf (&string [8], "%X", &ui1); /* test "plain vanilla" fmt */ if (i != 1) /* string; data contains */ goto Fail; /* the characters 0x */ if (ui1 != 0) goto Fail; ul1 = 0; /* test fmt string of max */ i = sscanf (&string [12], " D %12lxm", &ul1); /* field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test fmt string of max */ i = sscanf (&string [30], "%6lx%x", &ul1, &ui1); /* field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 0x7FED) || (ui1 != 16)) /* for integer */ goto Fail; printf ("Passed Conformance Test 17.8.0.12\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.12\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.13.CC b/Tests/Conformance/C17.8.0.13.CC new file mode 100755 index 0000000..8d7a027 --- /dev/null +++ b/Tests/Conformance/C17.8.0.13.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.13: Verification of sscanf, c format code */ #include #include main () { char sstr [] = "bten chars!andMore"; int i; char ch, string [50]; ch = 'a'; /* no assignment should be made */ i = sscanf (sstr, "%*hc"); /* h ignored */ if (i != 0) goto Fail; if (ch != 'a') goto Fail; i = sscanf (&sstr [1], "%10lc", string); /* test assignment to string*/ if (i != 1) /* l ignored */ goto Fail; if (strncmp (string, "ten chars!", 10)) goto Fail; printf ("Passed Conformance Test 17.8.0.13\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.13\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.14.CC b/Tests/Conformance/C17.8.0.14.CC new file mode 100755 index 0000000..19c68ef --- /dev/null +++ b/Tests/Conformance/C17.8.0.14.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.14: Verification of sscanf, s format code */ #include main () { char sstr [] = " oneLongWord ten-chars!andMore"; int i, j; char string [50] = "hey, hey!"; i = sscanf (&sstr[0], "%*hs"); /* no assignment made; h ignored */ if (i != 0) goto Fail; if (strcmp (string, "hey, hey!")) goto Fail; i = sscanf (&sstr [14], "%10ls", string); /* test assignment to string*/ if (i != 1) /* l ignored */ goto Fail; if (strcmp (string, "ten-chars!")) goto Fail; printf ("Passed Conformance Test 17.8.0.14\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.14\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.15.CC b/Tests/Conformance/C17.8.0.15.CC new file mode 100755 index 0000000..691c369 --- /dev/null +++ b/Tests/Conformance/C17.8.0.15.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.15: Verification of fscanf, f e E g G format codes */ #include #include main () { char sstr [] = " 23 -3.8E20 - e- +25e- 00002.00008e000049.9 "; float f1, f2, f3, f4; double d1, d2, d3; int i; f1 = f2 = f3 = f4 = 1.0; d1 = d2 = d3 = 1.0; i = sscanf (&sstr[0], "%*07f %e %E %lg %30lG %17lf%e", &f2, &f3, &d1, &d2, &d3, &f4); if (i != 6) goto Fail; if ((fabs(f1 - 1.0) > 0.00001) || (fabs(f2 - (-3.8E20)) > 1e15) || (fabs(f3) > 0.00001) || (fabs(f4 - 9.9) > 0.00001) || (fabs(d1) > 0.00001) || (fabs(d2 - 25.0) > 0.00001) || (fabs(d3 - 2.00008e4) > 0.00001)) goto Fail; printf ("Passed Conformance Test 17.8.0.15\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.15\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.16.CC b/Tests/Conformance/C17.8.0.16.CC new file mode 100755 index 0000000..2140385 --- /dev/null +++ b/Tests/Conformance/C17.8.0.16.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.16: Verification of sscanf, % and [ format codes */ #include main () { char sstr [] = "% these are the ^only[ characters" "*aaabbb a fine mess, you see! ddddfffffffff"; int i; char string [2] [50] = { {"hey, hey!"}, {"you, you"} }; i = sscanf (&sstr[0], "%*50h%"); /* no assignment made; * 50 h ignored */ if (i != 0) goto Fail; /* Create set of characters which can appear in the output string. */ i = sscanf (&sstr [1], "%45[thes aronlyc^[] %*[*ab]", &string [0]); if (i != 1) goto Fail; if (strcmp (&string [0], " these are the ^only[ characters")) goto Fail; /* Create set of characters which cannot appear in the output string. */ i = sscanf (&sstr [42], "%[^d] %10[df]", &string [0], &string [1]); if (i != 2) goto Fail; if (strcmp (&string [0], " a fine mess, you see! ")) goto Fail; if (strcmp (&string [1], "ddddffffff")) goto Fail; printf ("Passed Conformance Test 17.8.0.16\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.16\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.17.CC b/Tests/Conformance/C17.8.0.17.CC new file mode 100755 index 0000000..3e7f327 --- /dev/null +++ b/Tests/Conformance/C17.8.0.17.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.17: Verification of scanf, d format code */ #include main () { short i1; int i; int i2, i3; long L1; char ch; FILE *f1; /* Redirect standard input to a data file. */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " +327678 - -002147483647A 327677-22 123*\r"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; i1 = 0; /* test format string of no */ i = scanf ("%*05hd8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (i1 != 0) /* after 5 digits read */ goto Fail; i2 = 15; /* test "plain vanilla" fmt */ i = scanf ("%d", &i2); /* string; data contains */ if (i != 1) /* a single minus sign */ goto Fail; if (i2 != 0) goto Fail; L1 = 0; /* test format string of */ i = scanf ("%12ldA", &L1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character A must appear*/ if (L1 != -2147483647) /* after digits read */ goto Fail; L1 = 0; /* test format string of */ i = scanf ("%6ld%d", &L1, &i2); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((L1 != 327677) || (i2 != -22)) /* for integer */ goto Fail; i3 = 4; /* test format string of */ i = scanf ("%4hd", &i3); /* max. field width of 4, */ if (i != 1) /* short variable expectd,*/ goto Fail; /* character * must appear*/ if (i3 != 123) /* after digits read. In */ goto Fail; /* the input, the number */ /* of digits is only 3. */ i = scanf ("%c", &ch); /* Ensure offending * has */ if (i != 1) /* been left in input. */ goto Fail; if (ch != '*') goto Fail; i = scanf ("%c", &ch); /* Ensure scanf returns EOF */ if (i != 1) /* when EOF encountered. */ goto Fail; if (ch != '\n') goto Fail; i = scanf ("%c", &ch); if (i != EOF) goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.17\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.17\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.17\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.18.CC b/Tests/Conformance/C17.8.0.18.CC new file mode 100755 index 0000000..0a7d7cc --- /dev/null +++ b/Tests/Conformance/C17.8.0.18.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.18: Verification of scanf, u format code */ #include main () { int i; unsigned short us1; unsigned int ui1; unsigned long ul1; FILE *f1; /* Redirect standard input from a file. */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " 327678 D 4294967295m 32767722\r"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; ui1 = 2; /* test format string of no */ i = scanf ("%*05hu8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (ui1 != 2) /* after 5 digits read */ goto Fail; i = scanf ("%u", &ui1); /* test "plain vanilla" fmt */ if (i != 0) /* string; data contains */ goto Fail; /* the character 'D' */ ul1 = 0; /* test format string of */ i = scanf ("D %12ldm", &ul1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test format string of */ i = scanf ("%6lu%u", &ul1, &ui1); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 327677) || (ui1 != 22)) /* for integer */ goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.18\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.18\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.18\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.19.CC b/Tests/Conformance/C17.8.0.19.CC new file mode 100755 index 0000000..5ce4007 --- /dev/null +++ b/Tests/Conformance/C17.8.0.19.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.19: Verification of scanf, o format code */ #include main () { int i; unsigned short us1; unsigned int ui1; unsigned long ul1; FILE *f1; /* Redirect standard input from a file. */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " 77777 D 37777777777m 117777526"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; us1 = 2; /* test format string of no */ i = scanf ("%*05ho8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (us1 != 2) /* after 5 digits read */ goto Fail; i = scanf ("%o", &ui1); /* test "plain vanilla" fmt */ if (i != 0) /* string; data contains */ goto Fail; /* the character 'D' */ ul1 = 0; /* test format string of */ i = scanf ("D %12lom", &ul1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test format string of */ i = scanf ("%7lo%o", &ul1, &ui1); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 327677) || (ui1 != 22)) /* for integer */ goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.19\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.19\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.19\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.2.CC b/Tests/Conformance/C17.8.0.2.CC new file mode 100755 index 0000000..06a2833 --- /dev/null +++ b/Tests/Conformance/C17.8.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.2: Verification of fscanf, u format code */ #include main () { FILE *f1; int i; unsigned short us1; unsigned int ui1; unsigned long ul1; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " 327678 D 4294967295m 32767722\r"); rewind(f1); ui1 = 2; /* test format string of no */ i = fscanf (f1, "%*05hu8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (ui1 != 2) /* after 5 digits read */ goto Fail; i = fscanf (f1, "%u", &ui1); /* test "plain vanilla" fmt */ if (i != 0) /* string; data contains */ goto Fail; /* the character 'D' */ ul1 = 0; /* test format string of */ i = fscanf (f1, "D %12ldm", &ul1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test format string of */ i = fscanf (f1, "%6lu%u", &ul1, &ui1); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 327677) || (ui1 != 22)) /* for integer */ goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.2\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.2\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.2\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.20.CC b/Tests/Conformance/C17.8.0.20.CC new file mode 100755 index 0000000..8225dee --- /dev/null +++ b/Tests/Conformance/C17.8.0.20.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.20: Verification of scanf, x,X format codes */ #include main () { int i; unsigned short us1; unsigned int ui1; unsigned long ul1; FILE *f1; /* Redirect standard input from a file */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " 327678 0x D 0xFFFFFFFFm 0x7fEd0X10"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; us1 = 2; /* test format string of no */ i = scanf ("%*05hx8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (us1 != 2) /* after 5 digits read */ goto Fail; i = scanf ("%X", &ui1); /* test "plain vanilla" fmt */ if (i != 1) /* string; data contains */ goto Fail; /* the characters 0x */ if (ui1 != 0) goto Fail; ul1 = 0; /* test format string of */ i = scanf (" D %12lxm", &ul1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test format string of */ i = scanf ("%6lx%x", &ul1, &ui1); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 0x7FED) || (ui1 != 16)) /* for integer */ goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.20\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.20\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.20\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.21.CC b/Tests/Conformance/C17.8.0.21.CC new file mode 100755 index 0000000..ed8601a --- /dev/null +++ b/Tests/Conformance/C17.8.0.21.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.21: Verification of scanf, c format code */ #include #include main () { FILE *f1; int i; char ch, string [50]; /* Redirect standard input from a file */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, "bten chars!andMore"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; ch = 'a'; /* no assignment should be made */ i = scanf ("%*hc"); /* h ignored */ if (i != 0) goto Fail; if (ch != 'a') goto Fail; i = scanf ("%10lc", string); /* test assignment to string*/ if (i != 1) /* l ignored */ goto Fail; if (strncmp (string, "ten chars!", 10)) goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.21\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.21\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.21\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.22.CC b/Tests/Conformance/C17.8.0.22.CC new file mode 100755 index 0000000..4a10734 --- /dev/null +++ b/Tests/Conformance/C17.8.0.22.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.22: Verification of scanf, s format code */ #include main () { int i, j; char string [50] = "hey, hey!"; FILE *f1; /* Redirect standard input from a file */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " oneLongWord ten_chars!andMore"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; i = scanf ("%*hs"); /* no assignment made; h ignored */ if (i != 0) goto Fail; if (strcmp (string, "hey, hey!")) goto Fail; i = scanf ("%10ls", string); /* test assignment to string*/ if (i != 1) /* l ignored */ goto Fail; if (strcmp (string, "ten_chars!")) goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.22\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.22\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.22\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.23.CC b/Tests/Conformance/C17.8.0.23.CC new file mode 100755 index 0000000..38e6048 --- /dev/null +++ b/Tests/Conformance/C17.8.0.23.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.23: Verification of scanf, f e E g G format codes */ #include #include main () { float f1, f2, f3, f4; double d1, d2, d3; int i; FILE *f; /* Redirect standard input from a file */ f = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f == NULL) goto Fail1; fprintf(f, "23 -3.8E20 - e- +25e- 00002.00008e000049.9"); fclose(f); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; f1 = f2 = f3 = f4 = 1.0; d1 = d2 = d3 = 1.0; i = scanf ("%*07f %e %E %lg %30lG %17lf%e", &f2, &f3, &d1, &d2, &d3, &f4); if (i != 6) goto Fail; if ((fabs(f1 - 1.0) > 0.00001) || (fabs(f2 - (-3.8E20)) > 1e15) || (fabs(f3) > 0.00001) || (fabs(f4 - 9.9) > 0.00001) || (fabs(d1) > 0.00001) || (fabs(d2 - 25.0) > 0.00001) || (fabs(d3 - 2.00008e4) > 0.00001)) goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.23\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.23\n"); return; Fail1: printf ("Unable to redirect stdin for Conformance Test 17.8.0.23\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.24.CC b/Tests/Conformance/C17.8.0.24.CC new file mode 100755 index 0000000..de8173c --- /dev/null +++ b/Tests/Conformance/C17.8.0.24.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.24: Verification of scanf, % and [ format codes */ #include main () { int i; char string [2] [50] = { {"hey, hey!"}, {"you, you"} }; FILE *f1; /* Redirect standard input from a file */ f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, "%% these are the ^only[ characters*aaabbb a fine mess, " "you see! ddddfffffffff"); fclose(f1); stdin = freopen ("3/tmp", "r", stdin); if (stdin == NULL) goto Fail1; i = scanf ("%*50h%"); /* no assignment made; * 50 h ignored */ if (i != 0) goto Fail; /* Create set of characters which can appear in the output string. */ i = scanf ("%45[thes arohnlyc^[] %*[*ab]", &string [0]); if (i != 1) goto Fail; if (strcmp (&string [0], " these are the ^only[ characters")) goto Fail; /* Create set of characters which cannot appear in the output string. */ i = scanf ("%[^d] %10[df]", &string [0], &string [1]); if (i != 2) goto Fail; if (strcmp (&string [0], " a fine mess, you see! ")) goto Fail; if (strcmp (&string [1], "ddddffffff")) goto Fail; stdin = freopen (".CONSOLE", "r", stdin); /* reset stdin and quit */ if (stdin == NULL) goto Fail1; printf ("Passed Conformance Test 17.8.0.24\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.24\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.24\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.3.CC b/Tests/Conformance/C17.8.0.3.CC new file mode 100755 index 0000000..9ded319 --- /dev/null +++ b/Tests/Conformance/C17.8.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.3: Verification of fscanf, o format code */ #include main () { FILE *f1; int i; unsigned short us1; unsigned int ui1; unsigned long ul1; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " 77777 D 37777777777m 117777526"); rewind(f1); us1 = 2; /* test format string of no */ i = fscanf (f1, "%*05ho8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (us1 != 2) /* after 5 digits read */ goto Fail; i = fscanf (f1, "%o", &ui1); /* test "plain vanilla" fmt */ if (i != 0) /* string; data contains */ goto Fail; /* the character 'D' */ ul1 = 0; /* test format string of */ i = fscanf (f1, "D %13lom", &ul1); /* max. field width of 13,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test format string of */ i = fscanf (f1, "%7lo%o", &ul1, &ui1); /* max. field width of 7, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 327677) || (ui1 != 22)) /* for integer */ goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.3\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.3\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.3\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.3\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.4.CC b/Tests/Conformance/C17.8.0.4.CC new file mode 100755 index 0000000..44a7a7b --- /dev/null +++ b/Tests/Conformance/C17.8.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.4: Verification of fscanf, x,X format codes */ #include main () { FILE *f1; int i; unsigned short us1; unsigned int ui1; unsigned long ul1; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " 327678 0x D 0xFFFFFFFFm 0x7fEd0X10"); rewind(f1); us1 = 2; /* test format string of no */ i = fscanf (f1, "%*05hx8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (us1 != 2) /* after 5 digits read */ goto Fail; i = fscanf (f1, "%X", &ui1); /* test "plain vanilla" fmt */ if (i != 1) /* string; data contains */ goto Fail; /* the characters 0x */ if (ui1 != 0) goto Fail; ul1 = 0; /* test format string of */ i = fscanf (f1, " D %12lxm", &ul1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character m must appear*/ if (ul1 != 4294967295u) /* after digits read */ goto Fail; ul1 = 0; /* test format string of */ i = fscanf (f1, "%6lx%x", &ul1, &ui1); /* max. field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((ul1 != 0x7FED) || (ui1 != 16)) /* for integer */ goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.4\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.4\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.4\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.4\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.5.CC b/Tests/Conformance/C17.8.0.5.CC new file mode 100755 index 0000000..2803bfd --- /dev/null +++ b/Tests/Conformance/C17.8.0.5.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.5: Verification of fscanf, c format code */ #include #include main () { FILE *f1; int i; char ch, string [50]; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, "bten chars!andMore"); rewind(f1); ch = 'a'; /* no assignment should be made */ i = fscanf (f1, "%*hc"); /* h ignored */ if (i != 0) goto Fail; if (ch != 'a') goto Fail; i = fscanf (f1, "%10lc", string); /* test assignment to string*/ if (i != 1) /* l ignored */ goto Fail; if (strncmp (string, "ten chars!", 10)) goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.5\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.5\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.5\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.5\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.6.CC b/Tests/Conformance/C17.8.0.6.CC new file mode 100755 index 0000000..ed02fcd --- /dev/null +++ b/Tests/Conformance/C17.8.0.6.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.6: Verification of fscanf, s format code */ #include main () { FILE *f1; int i, j; char string [50] = "hey, hey!"; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, " oneLongWord ten_chars!andMore"); rewind(f1); i = fscanf (f1, "%*hs"); /* no assignment made; h ignored */ if (i != 0) goto Fail; if (strcmp (string, "hey, hey!")) goto Fail; i = fscanf (f1, "%10ls", string); /* test assignment to string*/ if (i != 1) /* l ignored */ goto Fail; if (strcmp (string, "ten_chars!")) goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.6\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.6\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.6\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.6\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.7.CC b/Tests/Conformance/C17.8.0.7.CC new file mode 100755 index 0000000..560602a --- /dev/null +++ b/Tests/Conformance/C17.8.0.7.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.7: Verification of fscanf, e format codes */ #include #include main () { FILE *f; float f1, f2, f3, f4; double d1, d2, d3; int i; f = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f == NULL) goto Fail1; fprintf(f, "23 -3.8E20 - e- +25e- 00002.00008e000049.9"); rewind(f); f1 = f2 = f3 = f4 = 1.0; d1 = d2 = d3 = 1.0; i = fscanf (f, "%*07f %e %E %lg %30lG %17lf%e", &f2, &f3, &d1, &d2, &d3, &f4); if (i != 6) goto Fail; if ((fabs(f1 - 1.0) > 0.00001) || (fabs(f2 - (-3.8E20)) > 1e15) || (fabs(f3) > 0.00001) || (fabs(f4 - 9.9) > 0.00001) || (fabs(d1) > 0.00001) || (fabs(d2 - 25.0) > 0.00001) || (fabs(d3 - 2.00008e4) > 0.0000001)) goto Fail; i = fclose (f); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.7\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.7\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.7\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.7\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.8.CC b/Tests/Conformance/C17.8.0.8.CC new file mode 100755 index 0000000..77d9d89 --- /dev/null +++ b/Tests/Conformance/C17.8.0.8.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.8: Verification of fscanf, % and [ format codes */ #include main () { FILE *f1; int i; char string [2] [50] = { {"hey, hey!"}, {"you, you"} }; f1 = fopen ("3/tmp", "wb+"); /* open input file for test */ if (f1 == NULL) goto Fail1; fprintf(f1, "%% these are the ^only[ characters*aaabbb a fine mess, " "you see! ddddfffffffff"); rewind(f1); i = fscanf (f1, "%*50h%"); /* no assignment made; * 50 h ignored */ if (i != 0) goto Fail; /* Create set of characters which can appear in the output string. */ i = fscanf (f1, "%45[thes aronlyc^[h] %*[*ab]", &string [0]); if (i != 1) goto Fail; if (strcmp (&string [0], " these are the ^only[ characters")) goto Fail; /* Create set of characters which cannot appear in the output string. */ i = fscanf (f1, "%[^d] %10[df]", &string [0], &string [1]); if (i != 2) goto Fail; if (strcmp (&string [0], " a fine mess, you see! ")) goto Fail; if (strcmp (&string [1], "ddddffffff")) goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.8.0.8\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.8\n"); return; Fail1: printf ("Unable to open input file for Conformance Test 17.8.0.8\n"); return; Fail2: printf ("Unable to close input file for Conformance Test 17.8.0.8\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.8.0.9.CC b/Tests/Conformance/C17.8.0.9.CC new file mode 100755 index 0000000..9400d49 --- /dev/null +++ b/Tests/Conformance/C17.8.0.9.CC @@ -0,0 +1 @@ +/* Conformance Test 17.8.0.9: Verification of scanf, d format code */ #include main () { char string [] = " +327678 - -002147483647A 327677-22 123*"; short i1; int i; int i2, i3; long L1; char ch; i1 = 0; /* test format string of no */ i = sscanf (string, "%*05hd8"); /* assignment, max. field */ if (i != 0) /* width of 5, h ignored, */ goto Fail; /* character 8 must appear*/ if (i1 != 0) /* after 5 digits read */ goto Fail; i2 = 15; /* test "plain vanilla" fmt */ i = sscanf (&string [9], "%d", &i2); /* string; data contains */ if (i != 1) /* a single minus sign */ goto Fail; if (i2 != 0) goto Fail; L1 = 0; /* test format string of */ i = sscanf (&string [15], "%12ldA", &L1); /* max. field width of 12,*/ if (i != 1) /* long variable expected,*/ goto Fail; /* character A must appear*/ if (L1 != -2147483647) /* after digits read */ goto Fail; L1 = 0; /* test fmt string of max */ i = sscanf (&string [31], "%6ld%d", &L1, &i2); /* field width of 6, */ if (i != 2) /* long variable expected,*/ goto Fail; /* followed by simple fmt */ if ((L1 != 327677) || (i2 != -22)) /* for integer */ goto Fail; i3 = 4; /* test format string of */ i = sscanf (&string [43], "%4hd*", &i3); /* max. field width of 4, */ if (i != 1) /* short variable expectd,*/ goto Fail; /* character * must appear*/ if (i3 != 123) /* after digits read. In */ goto Fail; /* the input, the number */ /* of digits is only 3. */ i = sscanf (&string [47], "%c", &ch); /* Ensure offending * has */ if (i != 1) /* been left in input. */ goto Fail; if (ch != '*') goto Fail; i = sscanf (&string [48], "%c", &ch); /* Ensure sscanf returns EOF*/ if (i != EOF) /* when EOF encountered. */ goto Fail; printf ("Passed Conformance Test 17.8.0.9\n"); return; Fail: printf ("Failed Conformance Test 17.8.0.9\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C17.9.0.1.CC b/Tests/Conformance/C17.9.0.1.CC new file mode 100755 index 0000000..de49156 --- /dev/null +++ b/Tests/Conformance/C17.9.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 17.9.0.1: Verification of fputc, putc, and putchar */ #include main () { FILE *f1; int i, j; char ch; f1 = fopen ("3/tmp", "w+"); /* open output file for test */ if (f1 == NULL) goto Fail1; /* Redirect standard output to a file */ stdout = freopen ("3/tmp2", "w+", stdout); if (stdout == NULL) goto Fail3; for (ch = 'A', i = 0; i < 26; i++) /* write uppercase alphabet to */ { /* output file */ j = fputc (ch, f1); /* test fputc */ if ((j == EOF) || ( ((char) j) != ch )) goto Fail; j = putc (ch, f1); /* test putc */ if ((j == EOF) || ( ((char) j) != ch )) goto Fail; j = putchar (ch); /* test putchar */ if ((j == EOF) || ( ((char) j) != ch )) goto Fail; ch++; } /* Check files' contents. */ rewind (f1); rewind (stdout); for (ch = 'A', i = 0; i < 26; i++) { if ( (j = fgetc (f1)) == EOF ) goto Fail; if ( ((char) (j)) != ch ) goto Fail; if ( (j = getc (f1)) == EOF ) goto Fail; if ( ((char) (j)) != ch ) goto Fail; if ( (j = fgetc (stdout)) == EOF ) goto Fail; if ( ((char) (j)) != ch ) goto Fail; ch++; } fclose(stdout); /* reset standard out */ i = fclose (f1); /* close the update file */ if (i == EOF) goto Fail2; printf ("Passed Conformance Test 17.9.0.1\n"); return; Fail: fprintf (stderr, "Failed Conformance Test 17.9.0.1\n"); return; Fail1: fprintf (stderr, "Unable to open input file for Conformance Test 17.9.0.1\n"); return; Fail2: fprintf (stderr, "Unable to close input file for Conformance Test 17.9.0.1\n"); return; Fail3: fprintf (stderr, "Unable to redirect stdout for Conformance Test 17.9.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C18.1.0.1.CC b/Tests/Conformance/C18.1.0.1.CC new file mode 100755 index 0000000..f8f46e4 --- /dev/null +++ b/Tests/Conformance/C18.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 18.1.0.1: Verification of calloc library function */ #include #include struct S { int i; extended e; char ch [40]; }; main () { char *rgn; int i; rgn = (char *) calloc (50, sizeof (struct S)); if (rgn == NULL) goto Fail1; for (i = 0; i < 2600; i++) { if (*rgn != 0) goto Fail; rgn += 1; } free (rgn); printf ("Passed Conformance Test 18.1.0.1\n"); return; Fail: printf("%u\n", i); printf ("Failed Conformance Test 18.1.0.1\n"); return; Fail1: printf ("Unable to allocate memory for Conformance Test 18.1.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C18.3.0.1.CC b/Tests/Conformance/C18.3.0.1.CC new file mode 100755 index 0000000..23fd8fd --- /dev/null +++ b/Tests/Conformance/C18.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 18.3.0.1: Verification of realloc library function */ #include #include #include struct S { int i; extended e; char ch [40]; }; main () { struct S *rgn, *ptr1; struct S s [3] = { {1, 1.0, "hey"}, {2, 2.0, "you"}, {3, 3.0, "person!"} }; /* Pass realloc a NULL pointer to initialally allocate some memory. */ rgn = (struct S *) realloc (NULL, 3 * (sizeof (struct S)) ); if (rgn == NULL) goto Fail1; /* Copy the structure array s into the allocated area. */ memcpy (rgn, s, sizeof (s)); /* Reallocate a larger area -- ensure initial contents are preserved. */ rgn = (struct S *) realloc (rgn, 5 * (sizeof (struct S)) ); if (rgn == NULL) goto Fail1; ptr1 = rgn; if ((ptr1->i != 1) || (fabs(ptr1->e - 1.0) > 0.00001)) goto Fail; if (strcmp (ptr1->ch, "hey")) goto Fail; ptr1 += 1; if ((ptr1->i != 2) || (fabs(ptr1->e - 2.0) > 0.00001)) goto Fail; if (strcmp (ptr1->ch, "you")) goto Fail; ptr1 += 1; if ((ptr1->i != 3) || (fabs(ptr1->e - 3.0) > 0.00001)) goto Fail; if (strcmp (ptr1->ch, "person!")) goto Fail; /* Ensure passing a size of 0 deallocates the memory. */ rgn = (struct S *) realloc (rgn, 0); if (rgn != NULL) goto Fail1; printf ("Passed Conformance Test 18.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 18.3.0.1\n"); return; Fail1: printf ("Unable to allocate memory for Conformance Test 18.3.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C19.1.0.1.CC b/Tests/Conformance/C19.1.0.1.CC new file mode 100755 index 0000000..54dd8a9 --- /dev/null +++ b/Tests/Conformance/C19.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.1.0.1: Verification of abs, fabs, labs functions */ #include #include main () { double d1 = -9.0; int i = -8; long L = -32767; d1 = fabs (1.0 + d1); if (fabs(d1 - 8.0) > 0.00001) goto Fail; i = abs (2 + i); if (i != 6) goto Fail; L = labs (5 + L); if (L != 32762) goto Fail; printf ("Passed Conformance Test 19.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.10.0.1.CC b/Tests/Conformance/C19.10.0.1.CC new file mode 100755 index 0000000..cb70d0b --- /dev/null +++ b/Tests/Conformance/C19.10.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.10.0.1: Verification of cosh, sinh, tanh library */ /* functions */ #include main () { double d1; d1 = sinh (0.0); if (d1 != 0.0) goto Fail; d1 = cosh (0.0); if (d1 != 1.0) goto Fail; d1 = tanh (0.0); if (d1 != 0.0) goto Fail; printf ("Passed Conformance Test 19.10.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.10.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.2.0.1.CC b/Tests/Conformance/C19.2.0.1.CC new file mode 100755 index 0000000..7afd935 --- /dev/null +++ b/Tests/Conformance/C19.2.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.2.0.1: Verification of div, ldiv library functions */ #include main () { div_t d1; ldiv_t ld1; d1 = div (-9, 3); if ((d1.quot != -3) || (d1.rem != 0)) goto Fail; ld1 = ldiv (-80, 7); if ((ld1.quot != -11) || (ld1.rem != -3)) goto Fail; printf ("Passed Conformance Test 19.2.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.3.0.1.CC b/Tests/Conformance/C19.3.0.1.CC new file mode 100755 index 0000000..df95aff --- /dev/null +++ b/Tests/Conformance/C19.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.3.0.1: Verification of ceil, floor, fmod functions */ #include main () { double d1; d1 = ceil (-3.26); if (fabs(d1 - (-3.0)) > 0.00001) goto Fail; d1 = floor (-3.26); if (fabs(d1 - (-4.0)) > 0.00001) goto Fail; d1 = fmod (-4.4, 2.0); if (fabs(d1 - (-0.4)) > 0.00001) goto Fail; d1 = fmod (-4.4, 0.0); if (fabs(d1 - (-4.4)) > 0.00001) goto Fail; printf ("Passed Conformance Test 19.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.4.0.1.CC b/Tests/Conformance/C19.4.0.1.CC new file mode 100755 index 0000000..b2aa237 --- /dev/null +++ b/Tests/Conformance/C19.4.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.4.0.1: Verification of exp, log, log10 functions */ #include main () { double d1; d1 = exp (0); if (fabs(d1 - 1.0) > 0.00001) goto Fail; d1 = log (1.0); if (fabs(d1) > 0.00001) goto Fail; d1 = log10 (100.00); if (fabs(d1 - 2.0) > 0.00001) goto Fail; printf ("Passed Conformance Test 19.4.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.6.0.1.CC b/Tests/Conformance/C19.6.0.1.CC new file mode 100755 index 0000000..616cc0b --- /dev/null +++ b/Tests/Conformance/C19.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.6.0.1: Verification of pow, sqrt library functions */ #include main () { double d1; d1 = pow (-3.0, 3.0); if (d1 != -27.0) goto Fail; d1 = pow (555.33e+10, 0.0); if (d1 != 1.0) goto Fail; d1 = pow (0.0, 234.77); if (d1 != 0.0) goto Fail; d1 = sqrt (81.0); if (d1 != 9.0) goto Fail; printf ("Passed Conformance Test 19.6.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.7.0.1.CC b/Tests/Conformance/C19.7.0.1.CC new file mode 100755 index 0000000..6350578 --- /dev/null +++ b/Tests/Conformance/C19.7.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.7.0.1: Verification of rand, srand library functions */ #include main () { int i, j, array1 [20], array30 [20]; for (i = 0; i < 20; i++) { j = rand (); if ((j < 0 ) || (j > 32767)) goto Fail; array1 [i] = j; } srand (30); for (i = 0; i < 20; i++) { j = rand (); if ((j < 0 ) || (j > 32767)) goto Fail; array30 [i] = j; } srand (1); for (i = 0; i < 20; i++) { j = rand (); if (j != array1 [i]) goto Fail; } srand (30); for (i = 0; i < 20; i++) { j = rand (); if (j != array30 [i]) goto Fail; } printf ("Passed Conformance Test 19.7.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.7.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.8.0.1.CC b/Tests/Conformance/C19.8.0.1.CC new file mode 100755 index 0000000..a51591e --- /dev/null +++ b/Tests/Conformance/C19.8.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.8.0.1: Verification of cos, sin, tan library functions */ #include main () { double d1; d1 = cos (1.0); if (fabs(d1 - 0.540302305) > 0.00001) goto Fail; d1 = sin (1.0); if (fabs(d1 - 0.841470984) > 0.00001) goto Fail; d1 = tan (1.0); if (fabs(d1 - 1.557407725) > 0.00001) goto Fail; printf ("Passed Conformance Test 19.8.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.8.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C19.9.0.1.CC b/Tests/Conformance/C19.9.0.1.CC new file mode 100755 index 0000000..0612c5d --- /dev/null +++ b/Tests/Conformance/C19.9.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 19.9.0.1: Verification of acos, asin, atan, atan2 library */ /* functions */ #include main () { double d1; d1 = acos (0.5); if (fabs(d1 - 1.047197551) > 0.00001) goto Fail; d1 = asin (0.5); if (fabs(d1 - 0.523598775) > 0.00001) goto Fail; d1 = atan (0.5); if (fabs(d1 - 0.463647609) > 0.00001) goto Fail; d1 = atan2 (2.0, 1.0); if (fabs(d1 - 1.107148718) > 0.00001) goto Fail; printf ("Passed Conformance Test 19.9.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.9.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.0.1.CC b/Tests/Conformance/C2.1.0.1.CC new file mode 100755 index 0000000..cdd1312 --- /dev/null +++ b/Tests/Conformance/C2.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.0.1: Verification of character set */ main () { char string1 [] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; char string2 [] = "abcdefghijklmnopqrstuvwxyz"; char string3 [] = "0123456789"; char string4 [] = " !\"#$%&\'()*+,-./"; char string5 [] = ":;<=>?@"; char string6 [] = "[\\]^_"; char string7 [] = "{|}~"; char string8 [] = "\b\t\v\f\r\a\?"; int encode, i; /* Create a string variable from the required characters and check */ /* its contents against the ASCII encodings for the characters. */ for (i = 0, encode = 0x41; i < 26; i++, encode++) if (string1 [i] != encode) goto Fail; for (i = 0, encode = 0x61; i < 26; i++, encode++) if (string2 [i] != encode) goto Fail; for (i = 0, encode = 0x30; i < 10; i++, encode++) if (string3 [i] != encode) goto Fail; for (i = 0, encode = 0x20; i < 15; i++, encode++) if (string4 [i] != encode) goto Fail; for (i = 0, encode = 0x3A; i < 7; i++, encode++) if (string5 [i] != encode) goto Fail; for (i = 0, encode = 0x5B; i < 5; i++, encode++) if (string6 [i] != encode) goto Fail; for (i = 0, encode = 0x7B; i < 4; i++, encode++) if (string7 [i] != encode) goto Fail; if (string8 [0] != 0x08) goto Fail; if (string8 [1] != 0x09) goto Fail; if (string8 [2] != 0x0B) goto Fail; if (string8 [3] != 0x0C) goto Fail; if (string8 [4] != 0x0D) goto Fail; if (string8 [5] != 0x07) goto Fail; if (string8 [6] != 0x3F) goto Fail; printf ("Passed Conformance Test 2.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 2.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.0.2.CC b/Tests/Conformance/C2.1.0.2.CC new file mode 100755 index 0000000..208560c --- /dev/null +++ b/Tests/Conformance/C2.1.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.0.2: Verification of ANSI C trigraphs */ ??=define ten 10 /* ??= is '#' */ main () ??< /* ??< is '{' */ int i; char a, b??(10??) = "abc"; /* ??( is '[' */ /* ??) is ']' */ if (ten != 10) goto Fail; if ((strcmp (b, "abc")) != 0) goto Fail; a = '??/n'; /* ??/ is '\' */ if (a != 0x0A) goto Fail; i = 5 ??/ * 8; i = 0x7F ??' 0x03; /* ??' is '^', XOR */ if (i != 0x7C) goto Fail; i = 0x45 ??! 0x03; /* ??! is '|', OR */ if (i != 0x47) goto Fail; i = ??-i; /* ??- is '~', bitwise negation */ if (i != 0xFFB8) goto Fail; printf ("Passed Conformance Test 2.1.0.2\n"); return; Fail: printf ("Failed Conformance Test 2.1.0.2\n"); ??> /* ??> is '}' */ \ No newline at end of file diff --git a/Tests/Conformance/C2.1.0.3.CC b/Tests/Conformance/C2.1.0.3.CC new file mode 100755 index 0000000..bfcbe59 --- /dev/null +++ b/Tests/Conformance/C2.1.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.0.3: Verification of ANSI C trigraphs in */ /* character constants */ main () { char a; a = '??='; /* ??= is '#' */ if (a != '#') goto Fail; a = '??/??/'; /* ??/ is '\' */ if (a != 0x5C) goto Fail; a = '??''; /* ??' is '^' */ if (a != '^') goto Fail; a = '??!'; /* ??! is '|' */ if (a != '|') goto Fail; a = '??-'; /* ??- is '~' */ if (a != '~') goto Fail; a = '??('; /* ??( is '[' */ if (a != '[') goto Fail; a = '??<'; /* ??< is '{' */ if (a != '{') goto Fail; a = '??)'; /* ??) is ']' */ if (a != ']') goto Fail; a = '??>'; /* ??> is '}' */ if (a != '}') goto Fail; printf ("Passed Conformance Test 2.1.0.3\n"); return; Fail: printf ("Failed Conformance Test 2.1.0.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.0.4.CC b/Tests/Conformance/C2.1.0.4.CC new file mode 100755 index 0000000..f52762c --- /dev/null +++ b/Tests/Conformance/C2.1.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.0.4: Verification of ANSI C trigraphs in */ /* character string constants */ main () { char a [] = "??=??/boh??'??!??-??(??boy"; if ((strcmp (a, "#\boh^|~[{]}boy")) != 0) goto Fail; printf ("Passed Conformance Test 2.1.0.4\n"); return; Fail: printf ("Failed Conformance Test 2.1.0.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.1.1.CC b/Tests/Conformance/C2.1.1.1.CC new file mode 100755 index 0000000..655d8f3 --- /dev/null +++ b/Tests/Conformance/C2.1.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.1.1: Verification of encoding for null */ #include main () { char string [4]; strcpy (string, ""); if (string [0] != 0) goto Fail; strcpy (string, "abc"); if (string [3] != 0) goto Fail; printf ("Passed Conformance Test 2.1.1.1\n"); return; Fail: printf ("Failed Conformance Test 2.1.1.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.1.2.CC b/Tests/Conformance/C2.1.1.2.CC new file mode 100755 index 0000000..87decb5 --- /dev/null +++ b/Tests/Conformance/C2.1.1.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.1.2: Verification of newline character */ main () { char string [10]; strcpy (string, "\n"); if (string [0] != 0x0A) goto Fail; strcpy (string, "abc\nf\ngh\n"); if (string [3] != 0x0A) goto Fail; if (string [5] != 0x0A) goto Fail; if (string [8] != 0x0A) goto Fail; printf ("Passed Conformance Test 2.1.1.2\n"); return; Fail: printf ("Failed Conformance Test 2.1.1.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.2.1.CC b/Tests/Conformance/C2.1.2.1.CC new file mode 100755 index 0000000..97634cb --- /dev/null +++ b/Tests/Conformance/C2.1.2.1.CC @@ -0,0 +1,2 @@ +main ( ) +{ printf ("Passed Conformance Test 2.1.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.2.2.CC b/Tests/Conformance/C2.1.2.2.CC new file mode 100755 index 0000000..60aa54b --- /dev/null +++ b/Tests/Conformance/C2.1.2.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.2.2: Ensure '\' can be used to continue source lines */ main () { int i; i = 5 * \ 6; if \ (i != 30) goto Fail; i = 200 \ - 7; if (\ i != 193) goto Fail; i = \ 7 + 7; if (i\ != 14) goto Fail; i \ += 1; if (i !=\ 15) goto Fail; printf ("Passed Conformance Test 2.1.2.2\n"); return; Fail: printf ("Failed Conformance Test 2.1.2.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.1.2.3.CC b/Tests/Conformance/C2.1.2.3.CC new file mode 100755 index 0000000..8adc705 --- /dev/null +++ b/Tests/Conformance/C2.1.2.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.1.2.3: Ensure '\' can be used to continue preprocessor */ /* lines */ #include \ #define CONSTANT \ 5 main () { if (CONSTANT != 5) printf ("Failed Conformance Test 2.1.2.3\n"); else printf ("Passed Conformance Test 2.1.2.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.2.0.1.CC b/Tests/Conformance/C2.2.0.1.CC new file mode 100755 index 0000000..47c2247 --- /dev/null +++ b/Tests/Conformance/C2.2.0.1.CC @@ -0,0 +1 @@ +/* Test 2.2.0.1: in-line comments */ main (/* This should be ignored */) /*{ brackets should not be seen }*/ { printf ("Passed Conformance Test 2.2.0.1\n"); /**//*****/} \ No newline at end of file diff --git a/Tests/Conformance/C2.2.0.2.CC b/Tests/Conformance/C2.2.0.2.CC new file mode 100755 index 0000000..c537e29 --- /dev/null +++ b/Tests/Conformance/C2.2.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.2.0.2: Comments crossing multiple lines */ main () { /* Should ignore this comment line as well as this comment line and this and this and this and this and this */ printf ("Passed Conformance Test 2.2.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.2.0.3.CC b/Tests/Conformance/C2.2.0.3.CC new file mode 100755 index 0000000..48c5eb2 --- /dev/null +++ b/Tests/Conformance/C2.2.0.3.CC @@ -0,0 +1 @@ +/* Conformance test 2.2.0.3: Comments in preprocessor lines */ #define ten /* ten: one greater than nine */ (2 * 5) main () { if (ten == 10) { printf ("Passed Conformance Test 2.2.0.3\n"); } else { printf ("Failed Conformance Test 2.2.0.3\n"); } } \ No newline at end of file diff --git a/Tests/Conformance/C2.2.0.4.CC b/Tests/Conformance/C2.2.0.4.CC new file mode 100755 index 0000000..50f3f1a --- /dev/null +++ b/Tests/Conformance/C2.2.0.4.CC @@ -0,0 +1 @@ +/* Conformance test 2.2.0.4: Comment characters in strings */ main () { if (strlen("/*") == 2) printf ("Passed Conformance Test 2.2.0.4\n"); else printf ("Failed Conformance Test 2.2.0.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.4.0.1.CC b/Tests/Conformance/C2.4.0.1.CC new file mode 100755 index 0000000..f59333d --- /dev/null +++ b/Tests/Conformance/C2.4.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.4.0.1: Ensure =+ is assigment followed by unary plus */ main () { int a; a = 3; a =+ 2; if (a == 2) printf ("Passed Conformance Test 2.4.0.1\n"); else printf ("Failed Conformance Test 2.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.4.0.2.CC b/Tests/Conformance/C2.4.0.2.CC new file mode 100755 index 0000000..34ae122 --- /dev/null +++ b/Tests/Conformance/C2.4.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.4.0.2: Ensure =- is assigment followed by unary minus */ main () { int a; a = 3; a =- 2; if (a == -2) printf ("Passed Conformance Test 2.4.0.2\n"); else printf ("Failed Conformance Test 2.4.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.1.CC b/Tests/Conformance/C2.5.0.1.CC new file mode 100755 index 0000000..d7c522d --- /dev/null +++ b/Tests/Conformance/C2.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.1: Test characters comprising identifiers for */ /* variables */ main () { int a_______________000000000000000000000000000000; short _____________________________________________9; long \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210; long \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321; char abc; char aBc; ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = 8; ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = 3; if (\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 != 8) goto Fail; if (\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 != 3) goto Fail; abc = 'a'; aBc = 'b'; if ((abc == 'b') || (aBc == 'a')) goto Fail; a_______________000000000000000000000000000000 = 32767; if (a_______________000000000000000000000000000000 != 0x7FFF) goto Fail; _____________________________________________9 = -4009; if (_____________________________________________9 != -4009) goto Fail; printf ("Passed Conformance Test 2.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.2.CC b/Tests/Conformance/C2.5.0.2.CC new file mode 100755 index 0000000..ad74e57 --- /dev/null +++ b/Tests/Conformance/C2.5.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.2: Test characters comprising function identifiers */ main () { extern double i_______________000000000000000000000000000000__________ (); extern float \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210____________01234567899876543210 (); extern long \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210____________0123456789987654321 (); double k; float t, realNum; long m; k = i_______________000000000000000000000000000000__________ (); if (k != 1.0e0) goto Fail; t = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210____________01234567899876543210 (); realNum = 2.5e1; if (realNum != 2.5e1) goto Fail; m = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210____________0123456789987654321 (4, 5); if (m != 20L) goto Fail; printf ("Passed Conformance Test 2.5.0.2\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.2\n"); } /************************************************************************/ double i_______________000000000000000000000000000000__________ () { return (1.); } /************************************************************************/ float \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210____________01234567899876543210 () { return (25.0); } /************************************************************************/ long \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210____________0123456789987654321 ( _a_very_long_long_long_long_long_000000088888888888_parameter, ____________________________________another_long_parameter ) int _a_very_long_long_long_long_long_000000088888888888_parameter, ____________________________________another_long_parameter; { return ( \ _a_very_long_long_long_long_long_000000088888888888_parameter * \ ____________________________________another_long_parameter ); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.3.CC b/Tests/Conformance/C2.5.0.3.CC new file mode 100755 index 0000000..5e2169b --- /dev/null +++ b/Tests/Conformance/C2.5.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.3: Test characters comprising identifiers for */ /* user-defined types */ main () { typedef short _____________________________________________9; typedef long \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210; typedef float \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321; ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 x; ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 y; _____________________________________________9 s; s = 0x7FFF; if (s != 32767) goto Fail; x = 0x7FFFFFFF; if (x != 2147483647) goto Fail; y = 97.5; if (y != .975e+2) goto Fail; printf ("Passed Conformance Test 2.5.0.3\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.4.CC b/Tests/Conformance/C2.5.0.4.CC new file mode 100755 index 0000000..670960b --- /dev/null +++ b/Tests/Conformance/C2.5.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.4: Test characters comprising identifiers for */ /* structures */ main () { struct _____________________________________________9 { int ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210; long ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 0123456789987654321; } abcDEF, ABCdef; struct _____________________________________________9 s; abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = 26; abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = 2147483647; ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = 25; ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = 2147483646; s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = -5; s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = -2147483647; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 == \ ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210) goto Fail; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 == \ s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210) goto Fail; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 == \ ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321) goto Fail; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 == \ s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321) goto Fail; printf ("Passed Conformance Test 2.5.0.4\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.5.CC b/Tests/Conformance/C2.5.0.5.CC new file mode 100755 index 0000000..7935def --- /dev/null +++ b/Tests/Conformance/C2.5.0.5.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.5: Test characters comprising identifiers for */ /* unions */ main () { union _____________________________________________9 { int ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210; long ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 0123456789987654321; } abcDEF, ABCdef; union _____________________________________________9 s; /* Assign and check 1st union field for each variable. */ abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = 26; ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = 25; s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 = -5; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 == \ ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210) goto Fail; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 == \ s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210) goto Fail; /* Assign and check 2nd union field for each variable. */ abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = 2147483647; ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = 2147483646; s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 = -2147483647; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 == \ ABCdef.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321) goto Fail; if (abcDEF.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 == \ s.\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321) goto Fail; printf ("Passed Conformance Test 2.5.0.5\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.6.CC b/Tests/Conformance/C2.5.0.6.CC new file mode 100755 index 0000000..6602d02 --- /dev/null +++ b/Tests/Conformance/C2.5.0.6.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.6: Test characters comprising identifiers for */ /* enumerations */ main () { enum _____________________________________________9 { ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210, ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 0123456789987654321 } abcDEF, ABCdef; enum _____________________________________________9 s; /* Assign and check 1st enum field for each variable. */ abcDEF = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210; ABCdef = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210; s = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210; if ((abcDEF != ABCdef) || (abcDEF != s) || (ABCdef != 0)) goto Fail; /* Assign and check 2nd union field for each variable. */ abcDEF = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321; ABCdef = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321; s = \ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321; if ((abcDEF != ABCdef) || (s != abcDEF) || (s != 1)) goto Fail; printf ("Passed Conformance Test 2.5.0.6\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.6\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.7.CC b/Tests/Conformance/C2.5.0.7.CC new file mode 100755 index 0000000..46aa74d --- /dev/null +++ b/Tests/Conformance/C2.5.0.7.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.7: Test characters comprising identifiers for */ /* preprocessor macros */ #define _____________________________________________9 10 #define ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210 20 #define ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz\ _____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz_____________01234567899876543210\ ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 0123456789987654321 30 main () { if (_____________________________________________9 != 10) goto Fail; if (ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210 != 20) goto Fail; if (ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321 != 30) goto Fail; printf ("Passed Conformance Test 2.5.0.7\n"); return; Fail: printf ("Failed Conformance Test 2.5.0.7\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.5.0.8.CC b/Tests/Conformance/C2.5.0.8.CC new file mode 100755 index 0000000..c636698 --- /dev/null +++ b/Tests/Conformance/C2.5.0.8.CC @@ -0,0 +1 @@ +/* Conformance Test 2.5.0.8: Test characters comprising identifiers for */ /* labels */ main () { goto _____________________________________________9; Fail: printf ("Failed Conformance Test 2.5.0.8\n"); _____________________________________________9: goto ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210; goto Fail; ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________01234567899876543210: goto ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321; goto Fail; ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_____________\ 01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrs\ tuvwxyz_____________01234567899876543210ABCDEFGHIJKLMNOPQRSTUVWXY\ Zabcdefghijklmnopqrstuvwxyz_____________0123456789987654321: printf ("Passed Conformance Test 2.5.0.8\n"); return; } \ No newline at end of file diff --git a/Tests/Conformance/C2.6.0.1.CC b/Tests/Conformance/C2.6.0.1.CC new file mode 100755 index 0000000..f0d57b3 --- /dev/null +++ b/Tests/Conformance/C2.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.6.0.1: Check if reserved words can be used as */ /* preprocessor macro names. All reserved */ /* words except GOTO, IF, and RETURN are */ /* checked. (They're used in the program) */ #define asm 1 #define auto 2 #define break 3 #define case 4 #define char 5 #define comp 6 #define const 7 #define continue 8 #define default 9 #define do 10 #define double 11 #define else 12 #define enum 13 #define extended 14 #define extern 15 #define float 16 #define for 17 #define inline 18 #define int 19 #define long 20 #define pascal 21 #define register 22 #define segment 23 #define short 24 #define signed 25 #define sizeof 26 #define static 27 #define struct 28 #define switch 29 #define typedef 30 #define union 31 #define unsigned 32 #define void 33 #define volatile 34 #define while 35 main () { if (asm != 1) goto Fail; if (auto != 2) goto Fail; if (break != 3) goto Fail; if (case != 4) goto Fail; if (char != 5) goto Fail; if (comp != 6) goto Fail; if (const != 7) goto Fail; if (continue != 8) goto Fail; if (default != 9) goto Fail; if (do != 10) goto Fail; if (double != 11) goto Fail; if (else != 12) goto Fail; if (enum != 13) goto Fail; if (extended != 14) goto Fail; if (extern != 15) goto Fail; if (float != 16) goto Fail; if (for != 17) goto Fail; if (inline != 18) goto Fail; if (int != 19) goto Fail; if (long != 20) goto Fail; if (pascal != 21) goto Fail; if (register != 22) goto Fail; if (segment != 23) goto Fail; if (short != 24) goto Fail; if (signed != 25) goto Fail; if (sizeof != 26) goto Fail; if (static != 27) goto Fail; if (struct != 28) goto Fail; if (switch != 29) goto Fail; if (typedef != 30) goto Fail; if (union != 31) goto Fail; if (unsigned != 32) goto Fail; if (void != 33) goto Fail; if (volatile != 34) goto Fail; if (while != 35) goto Fail; printf ("Passed Conformance Test 2.6.0.1\n"); return; Fail: printf ("Failed Conformance Test 2.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.6.0.2.CC b/Tests/Conformance/C2.6.0.2.CC new file mode 100755 index 0000000..50939c2 --- /dev/null +++ b/Tests/Conformance/C2.6.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.6.0.2: Check if reserved words can be used as */ /* preprocessor macro names */ #define goto 1 #define if 2 #define return 3 main () { while (goto != 1) { printf ("Failed Conformance Test 2.6.0.2\n"); exit (1); } while (if != 2) { printf ("Failed Conformance Test 2.6.0.2\n"); exit (1); } while (return != 3) { printf ("Failed Conformance Test 2.6.0.2\n"); exit (1); } printf ("Passed Conformance Test 2.6.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.6.0.3.CC b/Tests/Conformance/C2.6.0.3.CC new file mode 100755 index 0000000..71dba33 --- /dev/null +++ b/Tests/Conformance/C2.6.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.6.0.3: Ensure reserved words within identifiers are */ /* ignored */ main () { int asmm, auto_1, tbreak, casechar, continue_default, dodoubleelse; short _comp, extended_, inlinee, pascal0, segment_; long enum_external, floatforgoto, ifi, inty, longy, registerreturn; float short2, sizeofF, staticstruct, switch_, typedef0, union_; double unsignedNum, voidT, while_, aconst, isigned, _volatile; printf ("Passed Conformance Test 2.6.0.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.6.0.4.CC b/Tests/Conformance/C2.6.0.4.CC new file mode 100755 index 0000000..ae12578 --- /dev/null +++ b/Tests/Conformance/C2.6.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 2.6.0.4: Ensure reserved words within strings are ignored */ main () { char s0 [] = "asm"; char s1 [] = "auto"; char s2 [] = "break"; char s3 [] = "case"; char s4 [] = "char"; char s5 [] = "continue"; char s6 [] = "default"; char s7 [] = "do"; char s8 [] = "double"; char s9 [] = "else"; char s10[] = "enum"; char s11[] = "extern"; char s12[] = "float"; char s13[] = "for"; char s14[] = "goto"; char s15[] = "if"; char s16[] = "int"; char s17[] = "long"; char s18[] = "register"; char s19[] = "return"; char s20[] = "short"; char s21[] = "sizeof"; char s22[] = "static"; char s23[] = "struct"; char s24[] = "switch"; char s25[] = "typedef"; char s26[] = "union"; char s27[] = "unsigned"; char s28[] = "void"; char s29[] = "while"; char s30[] = "const"; char s31[] = "signed"; char s32[] = "volatile"; char s33[] = "comp"; char s34[] = "extended"; char s35[] = "inline"; char s36[] = "pascal"; char s37[] = "segment"; printf ("Passed Conformance Test 2.6.0.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.6.0.5.CC b/Tests/Conformance/C2.6.0.5.CC new file mode 100755 index 0000000..2f4efbc --- /dev/null +++ b/Tests/Conformance/C2.6.0.5.CC @@ -0,0 +1 @@ +/* Conformance Test 2.6.0.5: Ensure reserved words within comments are */ /* ignored */ main () { /* int auto, break, case, char, continue, default, do, double; */ /* long else, enum, extern, float, for, goto, if, int, long; */ /* float register, return, short, sizeof, static, struct, switch; */ /* double typedef, union, unsigned, void, while, const, signed; */ /* short volatile, asm, comp, extended, inline, pascal, segment; */ printf ("Passed Conformance Test 2.6.0.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.1.CC b/Tests/Conformance/C2.7.1.1.CC new file mode 100755 index 0000000..41c8ed9 --- /dev/null +++ b/Tests/Conformance/C2.7.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.1: Test decimal integer constants */ main () { int a; short b; /* Test maxint for Apple IIGS */ a = 32767; b = a; if ((a != 32767) || (b != 32767)) goto Fail; /* Test minint for Apple IIGS */ a = -32768; b = -32768; if ((a != -32768) || (b != -32768)) goto Fail; /* Test zero */ a = 0; b = 0; if ((a != 0) || (b != 0)) goto Fail; /* Test positive intermediate values */ a = 32766; b = a; if ((a != 32766) || (b != 32766)) goto Fail; /* Test negative intermediate values */ b = -32767; a = b; if ((a != -32767) || (b != -32767)) goto Fail; printf ("Passed Conformance Test 2.7.1.1\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.2.CC b/Tests/Conformance/C2.7.1.2.CC new file mode 100755 index 0000000..18dcf44 --- /dev/null +++ b/Tests/Conformance/C2.7.1.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.2: Test octal integer constants */ main () { int a; short b; /* Test maxint for Apple IIGS */ a = 077777; b = a; if ((a != 32767) || (b != 32767)) goto Fail; /* Test minint for Apple IIGS */ a = -0100000; b = a; if ((a != -32768) || (b != -32768)) goto Fail; /* Test zero */ a = 0; b = a; if ((a != 0) || (b != 0)) goto Fail; /* Test positive intermediate values */ a = 077776; b = a; if ((a != 32766) || (b != 32766)) goto Fail; /* Test negative intermediate values */ b = -077777; a = b; if ((a != -32767) || (b != -32767)) goto Fail; /* Test octal digit string with 255 characters */ a = \ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000007; printf ("Passed Conformance Test 2.7.1.2\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.3.CC b/Tests/Conformance/C2.7.1.3.CC new file mode 100755 index 0000000..16c9fb7 --- /dev/null +++ b/Tests/Conformance/C2.7.1.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.3: Test hexadecimal integer constants */ main () { int a; short b; /* Test maxint for Apple IIGS */ a = 0x7FFF; b = 0X7fff; if ((a != 32767) || (b != 32767)) goto Fail; /* Test minint for Apple IIGS */ a = -0X8000; b = -0x8000; if ((a != -32768) || (b != -32768)) goto Fail; /* Test zero */ a = 0x0; b = 0X00; if ((a != 0) || (b != 0)) goto Fail; /* Test positive intermediate values */ a = 0x7fFe; b = 0X7FfE; if ((a != 32766) || (b != 32766)) goto Fail; /* Test negative intermediate values */ b = -0x7fFF; a = -0X7FfF; if ((a != -32767) || (b != -32767)) goto Fail; /* Test hexadecimal digit string with 255 characters */ a = \ 0x0000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000007FF; if (a != 0x7FF) goto Fail; printf ("Passed Conformance Test 2.7.1.3\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.4.CC b/Tests/Conformance/C2.7.1.4.CC new file mode 100755 index 0000000..3ba0e27 --- /dev/null +++ b/Tests/Conformance/C2.7.1.4.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.4: Test decimal long integer constants */ main () { long a; long int b; /* Test maxlong for Apple IIGS */ a = 2147483647; b = a; if ((a != 2147483647) || (b != 2147483647)) goto Fail; /* Test zero */ a = 0L; b = 0l; if ((a != 0) || (b != 0)) goto Fail; /* Test positive intermediate values */ a = 2147483646; b = a; if ((a != 2147483646) || (b != 2147483646)) goto Fail; a = 32767L; b = a; if ((a != 32767) || (b != 0x7FFF)) goto Fail; printf ("Passed Conformance Test 2.7.1.4\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.5.CC b/Tests/Conformance/C2.7.1.5.CC new file mode 100755 index 0000000..7d71aec --- /dev/null +++ b/Tests/Conformance/C2.7.1.5.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.5: Test octal long integer constants */ main () { long a; long int b; /* Test maxlong for Apple IIGS */ a = 017777777777; b = a; if ((a != 2147483647) || (b != 2147483647)) goto Fail; /* Test maximum 32-bit octal value */ a = 037777777777; b = a; if ((a != 0xfFfFfFfF) || (b != 0XFFFFFFFF)) goto Fail; /* Test zero */ a = 000000000000L; b = 0l; if ((a != 0) || (b != 0)) goto Fail; /* Test positive intermediate values */ a = 017777777776; b = a; if ((a != 2147483646) || (b != 2147483646)) goto Fail; a = 077777; b = a; if ((a != 32767) || (b != 0x7FFF)) goto Fail; /* Test octal digit string with 255 characters */ a = \ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000007; printf ("Passed Conformance Test 2.7.1.5\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.6.CC b/Tests/Conformance/C2.7.1.6.CC new file mode 100755 index 0000000..0ba13a6 --- /dev/null +++ b/Tests/Conformance/C2.7.1.6.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.6: Test hexadecimal long integer constants */ main () { long a; long int b; /* Test maxlong for Apple IIGS */ a = 0x7FFFFFFF; b = 0X7fffFFff; if ((a != 2147483647) || (b != 2147483647)) goto Fail; /* Test minlong for Apple IIGS */ a = 0X80000000; b = 0x80000000; if ((a != -(2147483647 + 1)) || (b != -(2147483647 + 1))) goto Fail; /* Test zero */ a = 0x0; b = 0X00000000; if ((a != 0) || (b != 0)) goto Fail; /* Test positive intermediate values */ a = 0x7ffFfFfE; b = 0X7FFFFFfE; if ((a != 2147483646) || (b != 2147483646)) goto Fail; a = 0x7ffFl; b = 0X7FFFL; if ((a != 32767) || (b != 32767)) goto Fail; /* Test hexadecimal digit string with 255 characters */ a = \ 0X0000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000078A; if (a != 0x78A) goto Fail; printf ("Passed Conformance Test 2.7.1.6\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.6\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.7.CC b/Tests/Conformance/C2.7.1.7.CC new file mode 100755 index 0000000..51954cb --- /dev/null +++ b/Tests/Conformance/C2.7.1.7.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.7: Test unsigned integer constants */ main () { unsigned a; unsigned int b; unsigned short c; unsigned short int d; /* Test unsigned maxint for Apple IIGS */ a = b = 0xFFFF; c = 0177777; d = 65535u; if ((a != c) || (b != d)) goto Fail; /* Test zero */ a = 0; b = 0000; c = 0x0000; d = a; if ((a != 0) || (b != 0) || (c != 0) || (d != 0)) goto Fail; /* Test intermediate values */ a = 0x9AbC; b = 39612; c = d = 0115274; if ((a != b) || (b != d)) goto Fail; a = 32767; b = c = 077777; d = 0X7fFfU; if ((a != b) || (c != d)) goto Fail; /* Test octal digit string with 255 characters */ a = \ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000007; /* Test hexadecimal digit string with 255 characters */ a = \ 0x0000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000324; if (a != 0x324) goto Fail; printf ("Passed Conformance Test 2.7.1.7\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.7\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.1.8.CC b/Tests/Conformance/C2.7.1.8.CC new file mode 100755 index 0000000..c6c4172 --- /dev/null +++ b/Tests/Conformance/C2.7.1.8.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.1.8: Test unsigned long integer constants */ main () { unsigned long a; unsigned long int b; /* Test unsigned maxlong for Apple IIGS */ a = 0xFFFFffff; b = 037777777777; if ((a != (4294967295ul)) || (b != (4294967295UL))) goto Fail; /* Test zero */ a = 0; b = 0000; if ((a != 0) || (b != 0)) goto Fail; /* Test intermediate values */ a = 0x81347500; b = 020115072400; if ((a != 2167698688ul) || (b != 2167698688UL)) goto Fail; a = 2147545424uL; b = 2147545424Ul; if ((a != 0x8000f150) || (b != 020000170520)) goto Fail; /* Test octal digit string with 255 characters */ a = \ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000007uL; if (a != 7) goto Fail; /* Test hexadecimal digit string with 255 characters */ a = \ 0x0000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 000000000000000000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000271L; if (a != 0x271) goto Fail; printf ("Passed Conformance Test 2.7.1.8\n"); return; Fail: printf ("Failed Conformance Test 2.7.1.8\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.2.1.CC b/Tests/Conformance/C2.7.2.1.CC new file mode 100755 index 0000000..59cf4f4 --- /dev/null +++ b/Tests/Conformance/C2.7.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.2.1: Test single-precision floating-point constants */ #include main () { float a; /* Test maximum and minimum single-precision floating-point values, using */ /* all valid syntactic constructs. */ a = 1e+38; if (fabs(a - 1.E38) > 1e32) goto Fail; a = .1e-37; if (fabs(a - 0.1e-37) > 1e-42) goto Fail; /* Test other miscellaneous values. */ a = 32767.F; if (fabs(a - 32767.000E+00000) > 0.01) goto Fail; a = 123.4567; if (fabs(a - 1.234567E+02) > 0.001) goto Fail; a = 00000000; if (a != 0) goto Fail; a = .456789; if (fabs(a - 456789E-6) > 0.00001) goto Fail; /* Test negative values. */ a = -1e+38; if (fabs(a - (-1.E38)) > 1e33) goto Fail; a = -.1e-37; if (fabs(a - (-1.0e-38)) > 1e-42) goto Fail; /* Test other miscellaneous values. */ a = -32768.f; if (fabs(a - (-32768.000E+00000)) > 0.01) goto Fail; a = -123.4567; if (fabs(a - (-1.234567E+02)) > 0.001) goto Fail; a = -.456789; if (fabs(a - (-456789E-6)) > 0.00001) goto Fail; /* Test floating-point constant with many characters in a digit string */ a = \ 000000000000000000000000000000000000000000000000000000000000000000000000000007.0 ; if (fabs(a - 7.0) > 0.00001) goto Fail; printf ("Passed Conformance Test 2.7.2.1\n"); return; Fail: printf("Failed Conformance Test 2.7.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.2.2.CC b/Tests/Conformance/C2.7.2.2.CC new file mode 100755 index 0000000..76ce3e3 --- /dev/null +++ b/Tests/Conformance/C2.7.2.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.2.2: Test double-precision floating-point constants */ #include main () { double a; /* Test maximum and minimum double-precision floating-point values, using */ /* all valid syntactic constructs. */ a = 1e+308; if (fabs(a - 1.E308) > 1e302) goto Fail; a = .1e-307; if (fabs(a - 1.0e-308) > 1e-302) goto Fail; /* Test other miscellaneous values. */ a = 32767.f; if (fabs(a - 32767.000E+00000) > 0.1) goto Fail; a = 1234567.89012345; if (fabs(a - 1.23456789012345E+06) > 1.0) goto Fail; a = 000000000000000; if (fabs(a - 0) > 0.00001) goto Fail; a = .456789; if (fabs(a - 456789E-6) > 0.00001) goto Fail; /* Test negative values. */ a = -1e+308; if (fabs(a - (-1.E308)) > 1e-302) goto Fail; a = -.1e-307; if (fabs(a - (-1.0e-308)) > 1e-302) goto Fail; /* Test other miscellaneous values. */ a = -32768.F; if (fabs(a - (-32768.000E+00000)) > 0.1) goto Fail; a = -123.4567890123; if (fabs(a - (-1.234567E+02)) > 0.001) goto Fail; a = -.456789; if (fabs(a - (-456789E-6)) > 0.00001) goto Fail; printf ("Passed Conformance Test 2.7.2.2\n"); return; Fail: printf ("Failed Conformance Test 2.7.2.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.2.3.CC b/Tests/Conformance/C2.7.2.3.CC new file mode 100755 index 0000000..2c1bace --- /dev/null +++ b/Tests/Conformance/C2.7.2.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.2.3: Test extended-precision floating-pt constants */ #include main () { long double a; /* Test maximum and minimum extended-precision floating-point values, */ /* using all valid syntactic constructs. */ a = 1e+4932; if (fabs(a - 1.E4932) > 1e4927) goto Fail; a = .1e-4931; if (fabs(a - 1.0e-4932) > 1e-4928) goto Fail; /* Test other miscellaneous values. */ a = 32767l; if (fabs(a - 32767.000E+00000) > 0.1) goto Fail; a = 1234567890.123456789; if (fabs(a - 1.234567890123456789E+09) > 1000.0) goto Fail; a = 0000000000000000000; if (fabs(a) > 0.0000000001) goto Fail; a = .456789; if (fabs(a - 456789E-6) > 0.0000000001) goto Fail; /* Test negative values. */ a = -1e+4932; if (fabs(a - (-1.E4932)) > 1e4920) goto Fail; a = -.1e-4943; if (fabs(a - (-1.0e-4932)) > 1e-4935) goto Fail; /* Test other miscellaneous values. */ a = -32768L; if (fabs(a - (-32768.000E+00000)) > 0.0000000001) goto Fail; a = -123.4567890123; if (fabs(a - (-1.234567890123E+02)) > 0.000000001) goto Fail; a = -.456789; if (fabs(a - (-456789E-6)) > 0.0000000001) goto Fail; printf ("Passed Conformance Test 2.7.2.3\n"); return; Fail: printf ("Failed Conformance Test 2.7.2.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.3.1.CC b/Tests/Conformance/C2.7.3.1.CC new file mode 100755 index 0000000..bfac450 --- /dev/null +++ b/Tests/Conformance/C2.7.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.3.1: Check ASCII encodings for all character */ /* constants */ main () { char a; /* Check all printing characters. */ a = ' '; if (a != 0x20) goto Fail; a = '!'; if (a != 0x21) goto Fail; a = '"'; if (a != 0x22) goto Fail; a = '#'; if (a != 0x23) goto Fail; a = '$'; if (a != 0x24) goto Fail; a = '%'; if (a != 0x25) goto Fail; a = '&'; if (a != 0x26) goto Fail; a = '('; if (a != 0x28) goto Fail; a = ')'; if (a != 0x29) goto Fail; a = '*'; if (a != 0x2A) goto Fail; a = '+'; if (a != 0x2B) goto Fail; a = ','; if (a != 0x2C) goto Fail; a = '-'; if (a != 0x2D) goto Fail; a = '.'; if (a != 0x2E) goto Fail; a = '/'; if (a != 0x2F) goto Fail; a = '0'; if (a != 0x30) goto Fail; a = '1'; if (a != 0x31) goto Fail; a = '2'; if (a != 0x32) goto Fail; a = '3'; if (a != 0x33) goto Fail; a = '4'; if (a != 0x34) goto Fail; a = '5'; if (a != 0x35) goto Fail; a = '6'; if (a != 0x36) goto Fail; a = '7'; if (a != 0x37) goto Fail; a = '8'; if (a != 0x38) goto Fail; a = '9'; if (a != 0x39) goto Fail; a = ':'; if (a != 0x3A) goto Fail; a = ';'; if (a != 0x3B) goto Fail; a = '<'; if (a != 0x3C) goto Fail; a = '='; if (a != 0x3D) goto Fail; a = '>'; if (a != 0x3E) goto Fail; a = '?'; if (a != 0x3F) goto Fail; a = '@'; if (a != 0x40) goto Fail; a = 'A'; if (a != 0x41) goto Fail; a = 'B'; if (a != 0x42) goto Fail; a = 'C'; if (a != 0x43) goto Fail; a = 'D'; if (a != 0x44) goto Fail; a = 'E'; if (a != 0x45) goto Fail; a = 'F'; if (a != 0x46) goto Fail; a = 'G'; if (a != 0x47) goto Fail; a = 'H'; if (a != 0x48) goto Fail; a = 'I'; if (a != 0x49) goto Fail; a = 'J'; if (a != 0x4A) goto Fail; a = 'K'; if (a != 0x4B) goto Fail; a = 'L'; if (a != 0x4C) goto Fail; a = 'M'; if (a != 0x4D) goto Fail; a = 'N'; if (a != 0x4E) goto Fail; a = 'O'; if (a != 0x4F) goto Fail; a = 'P'; if (a != 0x50) goto Fail; a = 'Q'; if (a != 0x51) goto Fail; a = 'R'; if (a != 0x52) goto Fail; a = 'S'; if (a != 0x53) goto Fail; a = 'T'; if (a != 0x54) goto Fail; a = 'U'; if (a != 0x55) goto Fail; a = 'V'; if (a != 0x56) goto Fail; a = 'W'; if (a != 0x57) goto Fail; a = 'X'; if (a != 0x58) goto Fail; a = 'Y'; if (a != 0x59) goto Fail; a = 'Z'; if (a != 0x5A) goto Fail; a = '['; if (a != 0x5B) goto Fail; a = ']'; if (a != 0x5D) goto Fail; a = '^'; if (a != 0x5E) goto Fail; a = '_'; if (a != 0x5F) goto Fail; a = 'a'; if (a != 0x61) goto Fail; a = 'b'; if (a != 0x62) goto Fail; a = 'c'; if (a != 0x63) goto Fail; a = 'd'; if (a != 0x64) goto Fail; a = 'e'; if (a != 0x65) goto Fail; a = 'f'; if (a != 0x66) goto Fail; a = 'g'; if (a != 0x67) goto Fail; a = 'h'; if (a != 0x68) goto Fail; a = 'i'; if (a != 0x69) goto Fail; a = 'j'; if (a != 0x6A) goto Fail; a = 'k'; if (a != 0x6B) goto Fail; a = 'l'; if (a != 0x6C) goto Fail; a = 'm'; if (a != 0x6D) goto Fail; a = 'n'; if (a != 0x6E) goto Fail; a = 'o'; if (a != 0x6F) goto Fail; a = 'p'; if (a != 0x70) goto Fail; a = 'q'; if (a != 0x71) goto Fail; a = 'r'; if (a != 0x72) goto Fail; a = 's'; if (a != 0x73) goto Fail; a = 't'; if (a != 0x74) goto Fail; a = 'u'; if (a != 0x75) goto Fail; a = 'v'; if (a != 0x76) goto Fail; a = 'w'; if (a != 0x77) goto Fail; a = 'x'; if (a != 0x78) goto Fail; a = 'y'; if (a != 0x79) goto Fail; a = 'z'; if (a != 0x7A) goto Fail; a = '{'; if (a != 0x7B) goto Fail; a = '|'; if (a != 0x7C) goto Fail; a = '}'; if (a != 0x7D) goto Fail; a = '~'; if (a != 0x7E) goto Fail; /* Check all escape characters. */ a = '\n'; /* newline */ if (a != 0x0A) goto Fail; a = '\t'; /* horizontal tab */ if (a != 0x09) goto Fail; a = '\b'; /* back space */ if (a != 0x08) goto Fail; a = '\r'; /* carriage return */ if (a != 0x0D) goto Fail; a = '\f'; /* form feed */ if (a != 0x0C) goto Fail; a = '\v'; /* vertical tab */ if (a != 0x0B) goto Fail; a = '\''; /* apostrophe */ if (a != 0x27) goto Fail; a = '\"'; /* double quotes */ if (a != 0x22) goto Fail; a = '\\'; /* back slash */ if (a != 0x5C) goto Fail; a = '\a'; /* alert */ if (a != 0x07) goto Fail; a = '\?'; /* question mark */ if (a != 0x3F) goto Fail; printf ("Passed Conformance Test 2.7.3.1\n"); return; Fail: printf ("Failed Conformance Test 2.7.3.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.3.2.CC b/Tests/Conformance/C2.7.3.2.CC new file mode 100755 index 0000000..ef530dc --- /dev/null +++ b/Tests/Conformance/C2.7.3.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.3.2: Ensure char variables are implemented as */ /* unsigned 8-bit integers */ main () { char a; int i; for (i = 0; i < 256; i++) { a = i; if (a != i) goto Fail; } printf ("Passed Conformance Test 2.7.3.2\n"); return; Fail: printf ("Failed Conformance Test 2.7.3.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.4.1.CC b/Tests/Conformance/C2.7.4.1.CC new file mode 100755 index 0000000..e812c91 --- /dev/null +++ b/Tests/Conformance/C2.7.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.4.1: Test implementation of ORCA/C p-strings */ main () { char a [300]; strcpy (a, "\pabc"); /* "abc" should be a p-string */ if (a[0] != 3) goto Fail; strcpy (a, "\pThis is a longer string than the last one..."); if (a[0] != 44) goto Fail; strcpy (a, "not a \p-string"); if ((strcmp (a, "not a p-string")) != 0) goto Fail; printf ("Passed Conformance Test 2.7.4.1\n"); return; Fail: printf ("Failed Conformance Test 2.7.4.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.4.2.CC b/Tests/Conformance/C2.7.4.2.CC new file mode 100755 index 0000000..2974115 --- /dev/null +++ b/Tests/Conformance/C2.7.4.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.4.2: Ensure ability to define string constants */ /* across source lines */ main () { char s[300] = "The string begins here...\ and ends here!"; if (strcmp (s, "The string begins here... and ends here!")) goto Fail; strcpy (s, "another spl\ it string!"); if (strcmp (s, "another spl it string!")) goto Fail; printf ("Passed Conformance Test 2.7.4.2\n"); return; Fail: printf ("Failed Conformance Test 2.7.4.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.4.3.CC b/Tests/Conformance/C2.7.4.3.CC new file mode 100755 index 0000000..3b09510 --- /dev/null +++ b/Tests/Conformance/C2.7.4.3.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.4.3: Test strings of critical length in scanner */ #include #include main () { int i; char *strPtr; char s1 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789"; /* 99 bytes */ char s2 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789A"; /* 100 bytes */ char s3 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB"; /* 101 bytes */ char s4 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB" /* 100 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnop"; /* 17 bytes */ char s5 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB" /* 100 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopq"; /* 18 bytes */ char s8 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB" /* 100 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqr" /* 18 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789" /* 98 bytes */ "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ 0123456"; /* Test first set of critical lengths: 99, 100, 101 */ if (strcmp (s1, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789")) goto Fail; if (strcmp (s2, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789A")) goto Fail; if (strcmp (s3, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB")) goto Fail; /* Second set of critical lengths: 999, 1000, 1001 */ if (strncmp (s4, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB", 100)) goto Fail; strPtr = &s4 [100]; for (i = 1; i < 10; i++) { if (strncmp (strPtr, s1, 98)) goto Fail; strPtr += 98; } if (strcmp (strPtr, "abcdefghijklmnop")) goto Fail; if (strncmp (s5, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB", 100)) goto Fail; strPtr = &s5 [100]; for (i = 1; i < 10; i++) { if (strncmp (strPtr, s1, 98)) goto Fail; strPtr += 98; } if (strcmp (strPtr, "abcdefghijklmnopq")) goto Fail; /* Third set of critical lengths: 3999, 4000, 4001 */ if (strncmp (s8, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789AB", 100)) goto Fail; strPtr = &s8 [100]; for (i = 1; i < 10; i++) { if (strncmp (strPtr, s1, 98)) goto Fail; strPtr += 98; } if (strncmp (strPtr, "abcdefghijklmnopqr", 18)) goto Fail; strPtr += 18; for (i = 0; i < 30; i++) { if (strncmp (strPtr, s1, 98)) goto Fail; strPtr += 98; } if (strcmp (strPtr, "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ 0123456")) goto Fail; printf ("Passed Conformance Test 2.7.4.3\n"); return; Fail: printf ("Failed Conformance Test 2.7.4.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.4.4.CC b/Tests/Conformance/C2.7.4.4.CC new file mode 100755 index 0000000..b1c95d9 --- /dev/null +++ b/Tests/Conformance/C2.7.4.4.CC @@ -0,0 +1 @@ +main ( ) { char a [300] = \ "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"; printf("Passed Conformance Test 2.7.4.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.7.1.CC b/Tests/Conformance/C2.7.7.1.CC new file mode 100755 index 0000000..5a3450c --- /dev/null +++ b/Tests/Conformance/C2.7.7.1.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.7.1: Verification of numeric escape codes in */ /* character constants */ main () { char a; a = '\000'; if (a != '\x0') goto Fail; a = '\001'; if (a != '\x1') goto Fail; a = '\002'; if (a != '\x2') goto Fail; a = '\007'; /* alert character = bell */ if ((a != '\x7') || (a != '\a')) goto Fail; a = '\010'; /* back space */ if ((a != '\x8') || (a != '\b')) goto Fail; a = '\011'; /* horizontal tab */ if ((a != '\x9') || (a != '\t')) goto Fail; a = '\012'; /* line feed = newline */ if ((a != '\xA') || (a != '\n')) goto Fail; a = '\013'; /* vertical tab */ if ((a != '\xB') || (a != '\v')) goto Fail; a = '\014'; /* form feed */ if ((a != '\xC') || (a != '\f')) goto Fail; a = '\015'; /* carriage return */ if ((a != '\xD') || (a != '\r')) goto Fail; a = '\016'; if (a != '\xE') goto Fail; a = '\017'; if (a != '\xF') goto Fail; a = '\020'; if (a != '\x10') goto Fail; a = '\021'; if (a != '\x11') goto Fail; a = '\036'; if (a != '\x1E') goto Fail; a = '\037'; if (a != '\x1F') goto Fail; a = '\040'; /* blank */ if ((a != '\x20') || (a != ' ')) goto Fail; a = '\041'; /* exclamation point */ if ((a != '\x21') || (a != '!')) goto Fail; a = '\042'; /* double quote mark */ if ((a != '\x22') || (a != '"')) goto Fail; a = '\043'; /* pound sign */ if ((a != '\x23') || (a != '#')) goto Fail; a = '\044'; /* dollar sign */ if ((a != '\x24') || (a != '$')) goto Fail; a = '\045'; /* percent sign */ if ((a != '\x25') || (a != '%')) goto Fail; a = '\046'; /* ampersand */ if ((a != '\x26') || (a != '&')) goto Fail; a = '\047'; /* apostrophe */ if ((a != '\x27') || (a != '\'')) goto Fail; a = '\062'; /* character two */ if ((a != '\x32') || (a != '2')) goto Fail; a = '\063'; /* character three */ if ((a != '\x33') || (a != '3')) goto Fail; a = '\064'; /* character four */ if ((a != '\x34') || (a != '4')) goto Fail; a = '\065'; /* character five */ if ((a != '\x35') || (a != '5')) goto Fail; a = '\066'; /* character six */ if ((a != '\x36') || (a != '6')) goto Fail; a = '\077'; /* question mark */ if ((a != '\x3F') || (a != '?')) goto Fail; a = '\100'; /* at sign */ if ((a != '\x40') || (a != '@')) goto Fail; a = '\101'; if ((a != '\x41') || (a != 'A')) goto Fail; a = '\120'; if ((a != '\x50') || (a != 'P')) goto Fail; a = '\121'; if ((a != '\x51') || (a != 'Q')) goto Fail; a = '\122'; if ((a != '\x52') || (a != 'R')) goto Fail; a = '\123'; if ((a != '\x53') || (a != 'S')) goto Fail; a = '\124'; if ((a != '\x54') || (a != 'T')) goto Fail; a = '\125'; if ((a != '\x55') || (a != 'U')) goto Fail; a = '\126'; if ((a != '\x56') || (a != 'V')) goto Fail; a = '\127'; if ((a != '\x57') || (a != 'W')) goto Fail; a = '\130'; if ((a != '\x58') || (a != 'X')) goto Fail; a = '\131'; if ((a != '\x59') || (a != 'Y')) goto Fail; a = '\132'; if ((a != '\x5A') || (a != 'Z')) goto Fail; a = '\133'; /* left square bracket */ if ((a != '\x5B') || (a != '[')) goto Fail; a = '\134'; /* back slash */ if ((a != '\x5C') || (a != '\\')) goto Fail; a = '\135'; /* right square bracket */ if ((a != '\x5D') || (a != ']')) goto Fail; a = '\136'; /* caret mark */ if ((a != '\x5E') || (a != '^')) goto Fail; a = '\137'; /* underscore */ if ((a != '\x5F') || (a != '_')) goto Fail; a = '\140'; /* accent grave */ if ((a != '\x60') || (a != '`')) goto Fail; a = '\141'; if ((a != '\x61') || (a != 'a')) goto Fail; a = '\142'; if ((a != '\x62') || (a != 'b')) goto Fail; a = '\143'; if ((a != '\x63') || (a != 'c')) goto Fail; a = '\144'; if ((a != '\x64') || (a != 'd')) goto Fail; a = '\172'; if ((a != '\x7A') || (a != 'z')) goto Fail; a = '\173'; /* left curly bracket */ if ((a != '\x7B') || (a != '{')) goto Fail; a = '\174'; /* vertical bar */ if ((a != '\x7C') || (a != '|')) goto Fail; a = '\175'; /* right curly bracket */ if ((a != '\x7D') || (a != '}')) goto Fail; a = '\176'; /* tilde */ if ((a != '\x7E') || (a != '~')) goto Fail; a = '\177'; /* rubout */ if (a != '\x7F') goto Fail; printf ("Passed Conformance Test 2.7.7.1\n"); return; Fail: printf ("Failed Conformance Test 2.7.7.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C2.7.7.2.CC b/Tests/Conformance/C2.7.7.2.CC new file mode 100755 index 0000000..eefadd8 --- /dev/null +++ b/Tests/Conformance/C2.7.7.2.CC @@ -0,0 +1 @@ +/* Conformance Test 2.7.7.2: Verification of numeric escape codes */ /* within character strings */ main () { char a [300]; strcpy (a, "\07a\010b\011c\012d\013e\014f\015g\016h\017i\020j"); if ((strcmp (a, "\aa\bb\tc\nd\ve\ff\rg\xeh\xfi\x10j")) != 0) goto Fail; strcpy (a, "\021k\022l\023m\024n\025o\026p\027q\030r\031s\032t"); if ((strcmp (a, "\x11k\x12l\x13m\x14n\x15o\x16p\x17q\x18r\x19s\x1At")) != 0) goto Fail; strcpy (a, "\033u\034v\035w\036x\037y\040z\041a\042b\043c\044d"); if ((strcmp (a, "\x1bu\x1cv\x1dw\x1ex\x1fy z!a\"b#c$d")) != 0) goto Fail; strcpy (a, "\045e\046f\047g\050h\051i\052j\053k\054l\055m\056n\057o"); if ((strcmp (a, "%e&f'g(h)i*j+k,l-m.n/o")) != 0) goto Fail; strcpy (a, "\060p\061q\062r\063s\064t\065u\066v\067w\070x\071y\072z"); if ((strcmp (a, "0p1q2r3s4t5u6v7w8x9y:z")) != 0) goto Fail; strcpy (a, "\073A\074B\075C\076D\077E\100F\101G\102H\103I\104J"); if ((strcmp (a, ";AD?E@FAGBHCIDJ")) != 0) goto Fail; strcpy (a, "\105k\106l\107m\110n\111o\112p\113q\114r\115s"); if ((strcmp (a, "EkFlGmHnIoJpKqLrMs")) != 0) goto Fail; strcpy (a, "\116t\117u\120v\121w\122x\123y\124z\125A\126B"); if ((strcmp (a, "NtOuPvQwRxSyTzUAVB")) != 0) goto Fail; strcpy (a, "\127C\130D\131E\132F\133G\134H\135I\136J\137K"); if ((strcmp (a, "WCXDYEZF[G\x5cH]I^J_K")) != 0) goto Fail; strcpy (a, "\140L\141M\142N\143O\144P\145Q\146R\147S\150T"); if ((strcmp (a, "`LaMbNcOdPeQfRgShT")) != 0) goto Fail; strcpy (a, "\151U\152V\153W\154X\155Y\156Z\157A\160B\161C"); if ((strcmp (a, "iUjVkWlXmYnZoApBqC")) != 0) goto Fail; strcpy (a, "\162D\163E\164F\165G\166H\167I\170J\171K\172L"); if ((strcmp (a, "rDsEtFuGvHwIxJyKzL")) != 0) goto Fail; strcpy (a, "\173M\174N\175O\176P\177Q"); if ((strcmp (a, "{M|N}O~P\x7fQ")) != 0) goto Fail; printf ("Passed Conformance Test 2.7.7.2\n"); return; Fail: printf ("Failed Conformance Test 2.7.7.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C20.1.0.1.CC b/Tests/Conformance/C20.1.0.1.CC new file mode 100755 index 0000000..7182bd1 --- /dev/null +++ b/Tests/Conformance/C20.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 20.1.0.1: Verification of clock library function */ #include #include #include #include #include #include #include #include #include main () { clock_t clicks; char **dpHandle, *dPageAddr; int myID; struct TSInfo { int toolSet; /* Tool Locator table to */ int minVersion; }; /* load RAM-based tools */ struct ToolTable { int count; struct TSInfo tsInfo [2]; } toolTbl; /* In order to use the clock function, must ensure that Event Manager */ /* has been started. The Event Manager requires the Miscellaneous Toolset */ /* QuickDraw II, the Desk Manager, and the ADB Toolset. First allocate */ /* 4 pages of direct page workspace for the Event Manager and QD II. */ myID = userid (); dpHandle = NewHandle (1024L, myID, 0xC015, 0x00000000L); if ( toolerror () ) goto Fail1; if (dpHandle == NULL) goto Fail1; dPageAddr = *dpHandle; if (! (MTStatus ()) ) /* start the Miscellaneous Toolset */ MTStartUp (); if (! (QDStatus ()) ) /* start QuickDraw II */ { QDStartUp ((int) dPageAddr, 0, 0, myID); if ( toolerror () ) goto Fail2; } if (! (EMStatus ()) ) /* start Event Manager */ { EMStartUp (((int) dPageAddr) + 768, 0, 0, 640, 0, 200, myID); if ( toolerror () ) goto Fail3; } toolTbl.count = 2; /* load Desk Mgr & ADB tools */ toolTbl.tsInfo [0].toolSet = 5; toolTbl.tsInfo [1].toolSet = 9; toolTbl.tsInfo [0].minVersion = toolTbl.tsInfo [1].minVersion = 1; LoadTools ((void *) (&toolTbl)); if ( toolerror () ) goto Fail4; if (! (DeskStatus ()) ) /* start the Desk Manager */ DeskStartUp (); if (! (ADBStatus ()) ) /* start the Apple Desktop Bus */ ADBStartUp (); /* Finally, can call clock. */ clicks = clock (); /* Shut down the tools in the reverse order of start up. */ ADBShutDown (); DeskShutDown (); EMShutDown (); QDShutDown (); MTShutDown (); printf ("Passed Conformance Test 20.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 20.1.0.1\n"); Fail1: printf ("Unable to allocate direct page for Conformance Test 20.1.0.1\n"); Fail2: printf ("Unable to start QuickDraw II for Conformance Test 20.1.0.1\n"); Fail3: printf ("Unable to start Event Manager for Conformance Test 20.1.0.1\n"); Fail4: printf ("Unable to load RAM tools for Conformance Test 20.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C20.5.0.1.CC b/Tests/Conformance/C20.5.0.1.CC new file mode 100755 index 0000000..d2df21d --- /dev/null +++ b/Tests/Conformance/C20.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 20.5.0.1: Verification of difftime function */ #include #include main () { double d1; time_t t1, t0; long L; t0 = time (NULL); for (L = 0; L < 50000; L++) ; t1 = time (NULL); d1 = difftime (t1, t0); if (d1 < 0) goto Fail; printf ("Passed Conformance Test 20.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 20.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C21.1.0.2.CC b/Tests/Conformance/C21.1.0.2.CC new file mode 100755 index 0000000..fc8fd46 --- /dev/null +++ b/Tests/Conformance/C21.1.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 21.1.0.2: Verification of assert, ndebug macros */ #include #define NDEBUG 1 main () { int i = 7; assert (i == 7); printf ("Passed Conformance Test 21.1.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C21.4.0.1.CC b/Tests/Conformance/C21.4.0.1.CC new file mode 100755 index 0000000..3f38763 --- /dev/null +++ b/Tests/Conformance/C21.4.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 21.4.0.1: Verification of setjmp, longjmp functions */ #include jmp_buf env; /* setjmp, longjmp environment array */ /*****************************************************************************/ void F1 (char ch) { if (ch == 'a') longjmp (env, 0); /* not allowed to do this -- should */ else /* cause setjmp to return a 1 */ longjmp (env, 2); } /*****************************************************************************/ main () { int i; i = setjmp (env); /* initialize env to main's environment */ if (i == 0) F1 ('a'); else if (i == 1) /* check second return from setjmp */ { printf ("Passed Conformance Test 21.4.0.1\n"); return; } else printf ("Failed Conformance Test 21.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C22.5.0.1.CC b/Tests/Conformance/C22.5.0.1.CC new file mode 100755 index 0000000..4d5c534 --- /dev/null +++ b/Tests/Conformance/C22.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 22.5.0.1: Verification of bsearch, qsort functions */ #include #include /******************************************************************************/ int Compare (int *i1, int *i2) { if (*i1 < *i2) return (-1); else if (*i1 > *i2) return (1); else return 0; } /******************************************************************************/ main () { int i [10] = { 3, 4, 6, 8, 0, 2, 1, 5, 3, 7 }; int j, *iptr; /* First sort the array with the qsort routine, then check results. */ qsort ( (int *) (i), 10, sizeof (int), Compare ); for (j = 0; j < 4; j++) if (i [j] != j) goto Fail; for (j = 3; j < 9; j++) if (i [j+1] != j) goto Fail; /* Now call bsearch to find some values in the array. */ j = 7; iptr = (int *) bsearch ( &j, i, 10, sizeof (int), Compare ); if (iptr != &i [8]) goto Fail; j = 0; iptr = (int *) bsearch ( &j, i, 10, sizeof (int), Compare ); if (iptr != i) goto Fail; j = -3; iptr = (int *) bsearch ( &j, i, 10, sizeof (int), Compare ); if (iptr != NULL) goto Fail; printf ("Passed Conformance Test 22.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 22.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C23.1.0.1.CC b/Tests/Conformance/C23.1.0.1.CC new file mode 100755 index 0000000..18bc40f --- /dev/null +++ b/Tests/Conformance/C23.1.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 23.1.0.1: Verification of c2pstr, p2cstr functions */ #include main () { char *ptr; char pstring [] = "\pThis is a so-called Pascal string"; char cstring [] = "This string is 289 characters long: a b c d e f g h i j " "a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M " "a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M " "a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M"; ptr = c2pstr (cstring); if ( ptr[0] != 255 ) goto Fail; if (! (strcmp (ptr, "\pThis string is 289 characters long: a b c d e f g h i \ j a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L \ M a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L \ M a b c d e f g h i j k l m n o p q r s t u v")) ) goto Fail; ptr = p2cstr (pstring); if ( (strlen (ptr)) != 33 ) goto Fail; if (strcmp (ptr, "This is a so-called Pascal string")) goto Fail; printf ("Passed Conformance Test 23.1.0.1\n"); return; Fail: printf ("Failed Conformance Test 23.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C23.2.0.1.CC b/Tests/Conformance/C23.2.0.1.CC new file mode 100755 index 0000000..98aabdf --- /dev/null +++ b/Tests/Conformance/C23.2.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 23.2.0.1: Make sure the rtl pragma works */ #pragma rtl #include int main (void) { SYSIOSTARTUP(); printf ("Passed Conformance Test 23.2.0.1\n"); SYSIOSHUTDOWN(); return; } \ No newline at end of file diff --git a/Tests/Conformance/C23.3.0.1.CC b/Tests/Conformance/C23.3.0.1.CC new file mode 100755 index 0000000..60138f8 --- /dev/null +++ b/Tests/Conformance/C23.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 23.3.0.1: Verification of shellid function */ #include main () { char *id; id = shellid (); if (strcmp (id, "BYTEWRKS")) goto Fail; printf ("Passed Conformance Test 23.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 23.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C23.4.0.1.CC b/Tests/Conformance/C23.4.0.1.CC new file mode 100755 index 0000000..5e15b58 --- /dev/null +++ b/Tests/Conformance/C23.4.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 23.4.0.1: Verification of startdesk, enddesk functions */ #include main () { startdesk (640); if ( toolerror () ) goto Fail; enddesk (); if ( toolerror () ) goto Fail; printf ("Passed Conformance Test 23.4.0.1\n"); return; Fail: printf ("Failed Conformance Test 23.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C23.5.0.1.CC b/Tests/Conformance/C23.5.0.1.CC new file mode 100755 index 0000000..9176e02 --- /dev/null +++ b/Tests/Conformance/C23.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 23.5.0.1: Verification of startgraph, endgraph functions */ #include main () { startgraph (640); if ( toolerror () ) goto Fail; endgraph (); if ( toolerror () ) goto Fail; printf ("Passed Conformance Test 23.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 23.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C23.6.0.1.CC b/Tests/Conformance/C23.6.0.1.CC new file mode 100755 index 0000000..32a40eb --- /dev/null +++ b/Tests/Conformance/C23.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 23.6.0.1: Make sure the lint pragma is alive */ #pragma lint -1 #include int main (void) { printf ("Passed Conformance Test 23.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C24.0.1.CC b/Tests/Conformance/C24.0.1.CC new file mode 100755 index 0000000..3727e9e --- /dev/null +++ b/Tests/Conformance/C24.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 24.0.1: Verification of floating-point expressions for */ /* 68881 card */ #define SLOT 3 #define __FPE__ SLOT #pragma float 1 SLOT #include #include float f = 3.5; double d = 87.65; extended e = 92.33; int i, j, k, m; int sub1(void) { f++; d++; e++; /* test postincrement */ if ((fabs(f - 4.5) > 0.00001) || (fabs(d - 88.65) > 0.00001) || (fabs(e - 93.33) > 0.00001)) goto Fail; f--; d--; e--; /* test postdecrement */ if ((fabs(f - 3.5) > 0.00001) || (fabs(d - 87.65) > 0.00001) || (fabs(e - 92.33) > 0.00001)) goto Fail; f = f * 2.4; d = d * (-7.2); e = e * 9.22; /* multiplication */ if ((fabs(f - 8.4) > 0.00001) || (fabs(d - (-631.08)) > 0.00001) || (fabs(e - 851.2826) > 0.00001)) goto Fail; f = f / 2.0; d = d / -3.0; e = e / 0.2; /* division */ if ((fabs(f - 4.2) > 0.00001) || (fabs(d - 210.36) > 0.00001) || (fabs(e - 4256.413) > 0.00001)) goto Fail; i = f < d; j = d <= e; k = e > f; m = e >= e; /* relational operators */ if ((i != 1) || (j != 1) || (k != 1) || (m != 1)) goto Fail; return 0; Fail: return 1; } int sub2(void) { i = 0 && e--; j = f && 0; k = d++ && --f; /* logical AND operator */ if ((i != 0) || (j != 0) || (k != 1) || (fabs(e - 4256.413) > 0.00001) || (fabs(d - 211.36) > 0.00001) || (fabs(f - 3.2) > 0.00001)) goto Fail; i = 0 || e--; j = f || 0; k = d++ || --f; /* logical OR operator */ if ((i != 1) || (j != 1) || (k != 1) || (fabs(e - 4255.413) > 0.00001) || (fabs(d - 212.36) > 0.00001) || (fabs(f - 3.2) > 0.00001)) goto Fail; f = e ? 8 >> 1: d--; /* conditional expression */ if ((fabs(f - 4.0) > 0.00001) || (fabs(d - 212.36) > 0.00001)) goto Fail; return 0; Fail: return 1; } int sub3(void) { d += 5; e -= 8.9; f *= 3.0; /* compound assignment */ if ((fabs(f - 12.0) > 0.00001) || (fabs(d - 217.36) > 0.00001) || (fabs(e - 4246.513) > 0.00001)) goto Fail; f /= -0.4; if (fabs(f - (-30.0)) > 0.00001) goto Fail; f = (e = ((extended) (long) (e * 2.0)), d--, d--); /* comma operator */ if ((fabs(f - 216.36) > 0.00001) || (fabs(d - 215.36) > 0.00001) || (fabs(e - 8493.0) > 0.00001)) goto Fail; return 0; Fail: return 1; } main () { if (sub1()) goto Fail; if (sub2()) goto Fail; if (sub3()) goto Fail; printf ("Passed Conformance Test 24.0.1\n"); return; Fail: printf ("Failed Conformance Test 24.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C24.0.2.CC b/Tests/Conformance/C24.0.2.CC new file mode 100755 index 0000000..c78449a --- /dev/null +++ b/Tests/Conformance/C24.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 24.0.2: Test // comments and the ability to ignore */ /* them */ #pragma keep "t" #pragma lint -1 #include typedef enum {false, true} boolean; boolean pass; /* by default, // comments are allowed */ void Test1 (void) { int a; a = 8 //* this is a test */ 2 ; if (a == 4) pass = false; } #pragma ignore 0 /* now // comments are not allowed */ void Test2 (void) { int a; a = 8 //* this is a test */ 2 ; if (a == 8) pass = false; } int main (void) { pass = true; Test1(); Test2(); if (pass) printf("Passed Conformance Test 24.0.2\n"); else printf("Failed Conformance Test 24.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.1.CC b/Tests/Conformance/C25.0.1.CC new file mode 100755 index 0000000..2a2886d --- /dev/null +++ b/Tests/Conformance/C25.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.1: Verification of code generation for ADC instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i; int count = 0; asm { brl Test Code: ADC #0xF ADC DP ADC DP,X ADC ABS ADC ABS,X ADC ABS,Y ADC (DP),Y ADC (DP,X) ADC (DP) ADC DP,S ADC (DP,S),Y ADC LONG ADC LONG,X ADC [DP] ADC [DP],Y End: Data: dcb 0x69 dcb 0x0F dcb 0x00 dcb 0x65 dcb 0x02 dcb 0x75 dcb 0x02 dcb 0x6D dcb 0x00 dcb 0x08 dcb 0x7D dcb 0x00 dcb 0x08 dcb 0x79 dcb 0x00 dcb 0x08 dcb 0x71 dcb 0x02 dcb 0x61 dcb 0x02 dcb 0x72 dcb 0x02 dcb 0x63 dcb 0x02 dcb 0x73 dcb 0x02 dcb 0x6F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x7F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x67 dcb 0x02 dcb 0x77 dcb 0x02 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 inc count dex dex bpl Lbl1 stz i bra Out Err1: lda #1 sta i Out: } /* printf (" i = %d count = %d\n", i, count); */ if (i) goto Fail; printf ("Passed Conformance Test 25.0.1\n"); return; Fail: printf ("Failed Conformance Test 25.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.10.CC b/Tests/Conformance/C25.0.10.CC new file mode 100755 index 0000000..cb11ee0 --- /dev/null +++ b/Tests/Conformance/C25.0.10.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.10: Verification of code generation for CPX, CPY */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: CPX #0x1234 CPX DP CPX ABS CPY #0x1234 CPY DP CPY ABS Data: dcb 0xE0 dcb 0x34 dcb 0x12 dcb 0xE4 dcb 0x02 dcb 0xEC dcb 0x00 dcb 0x08 dcb 0xC0 dcb 0x34 dcb 0x12 dcb 0xC4 dcb 0x02 dcb 0xCC dcb 0x00 dcb 0x08 Test: ldx #14 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.10\n"); return; Fail: printf ("Failed Conformance Test 25.0.10\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.11.CC b/Tests/Conformance/C25.0.11.CC new file mode 100755 index 0000000..320e4e1 --- /dev/null +++ b/Tests/Conformance/C25.0.11.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.11: Verification of code generation for DEC instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: DEC A DEC DP DEC DP,X DEC ABS DEC ABS,X dcb 0 Data: dcb 0x3A dcb 0xC6 dcb 0x02 dcb 0xD6 dcb 0x02 dcb 0xCE dcb 0x00 dcb 0x08 dcb 0xDE dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #10 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.11\n"); return; Fail: printf ("Failed Conformance Test 25.0.11\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.12.CC b/Tests/Conformance/C25.0.12.CC new file mode 100755 index 0000000..2f8ab57 --- /dev/null +++ b/Tests/Conformance/C25.0.12.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.12: Verification of code generation for INC instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: INC A INC DP INC DP,X INC ABS INC ABS,X dcb 0 Data: dcb 0x1A dcb 0xE6 dcb 0x02 dcb 0xF6 dcb 0x02 dcb 0xEE dcb 0x00 dcb 0x08 dcb 0xFE dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #10 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.12\n"); return; Fail: printf ("Failed Conformance Test 25.0.12\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.13.CC b/Tests/Conformance/C25.0.13.CC new file mode 100755 index 0000000..17999d8 --- /dev/null +++ b/Tests/Conformance/C25.0.13.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.13: Verification of code generation for LDX instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { brl Test Code: LDX #0x1234 LDX DP LDX DP,Y LDX ABS LDX ABS,Y dcb 0 Data: dcb 0xA2 dcb 0x34 dcb 0x12 dcb 0xA6 dcb 0x02 dcb 0xB6 dcb 0x02 dcb 0xAE dcb 0x00 dcb 0x08 dcb 0xBE dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #12 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.13\n"); return; Fail: printf ("Failed Conformance Test 25.0.13\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.14.CC b/Tests/Conformance/C25.0.14.CC new file mode 100755 index 0000000..25f06e2 --- /dev/null +++ b/Tests/Conformance/C25.0.14.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.14: Verification of code generation for LDY instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { brl Test Code: LDY #0x1234 LDY DP LDY DP,X LDY ABS LDY ABS,X dcb 0 Data: dcb 0xA0 dcb 0x34 dcb 0x12 dcb 0xA4 dcb 0x02 dcb 0xB4 dcb 0x02 dcb 0xAC dcb 0x00 dcb 0x08 dcb 0xBC dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #12 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.14\n"); return; Fail: printf ("Failed Conformance Test 25.0.14\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.15.CC b/Tests/Conformance/C25.0.15.CC new file mode 100755 index 0000000..bc15535 --- /dev/null +++ b/Tests/Conformance/C25.0.15.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.15: Verification of code generation for LSR instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { brl Test Code: LSR A LSR DP LSR DP,X LSR ABS LSR ABS,X dcb 0 Data: dcb 0x4A dcb 0x46 dcb 0x02 dcb 0x56 dcb 0x02 dcb 0x4E dcb 0x00 dcb 0x08 dcb 0x5E dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #10 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.15\n"); return; Fail: printf ("Failed Conformance Test 25.0.15\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.16.CC b/Tests/Conformance/C25.0.16.CC new file mode 100755 index 0000000..5bbe30d --- /dev/null +++ b/Tests/Conformance/C25.0.16.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.16: Verification of code generation for ROL instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { brl Test Code: ROL A ROL DP ROL DP,X ROL ABS ROL ABS,X dcb 0 Data: dcb 0x2A dcb 0x26 dcb 0x02 dcb 0x36 dcb 0x02 dcb 0x2E dcb 0x00 dcb 0x08 dcb 0x3E dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #10 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.16\n"); return; Fail: printf ("Failed Conformance Test 25.0.16\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.17.CC b/Tests/Conformance/C25.0.17.CC new file mode 100755 index 0000000..a841509 --- /dev/null +++ b/Tests/Conformance/C25.0.17.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.17: Verification of code generation for ROR instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: ROR A ROR DP ROR DP,X ROR ABS ROR ABS,X dcb 0 Data: dcb 0x6A dcb 0x66 dcb 0x02 dcb 0x76 dcb 0x02 dcb 0x6E dcb 0x00 dcb 0x08 dcb 0x7E dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #10 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.17\n"); return; Fail: printf ("Failed Conformance Test 25.0.17\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.18.CC b/Tests/Conformance/C25.0.18.CC new file mode 100755 index 0000000..ac7f356 --- /dev/null +++ b/Tests/Conformance/C25.0.18.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.18: Verification of code generation for BIT instr */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: BIT #0x1234 BIT DP BIT DP,X BIT ABS BIT ABS,X dcb 0 Data: dcb 0x89 dcb 0x34 dcb 0x12 dcb 0x24 dcb 0x02 dcb 0x34 dcb 0x02 dcb 0x2C dcb 0x00 dcb 0x08 dcb 0x3C dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #12 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.18\n"); return; Fail: printf ("Failed Conformance Test 25.0.18\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.19.CC b/Tests/Conformance/C25.0.19.CC new file mode 100755 index 0000000..6797236 --- /dev/null +++ b/Tests/Conformance/C25.0.19.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.19: Verification of code generation for branch */ /* instructions */ #include main () { int i = 0; asm { brl Test Code: D1: BCC D1 D2: BCC D2 D3: BCS D3 D4: BCS D4 D5: BEQ D5 D6: BMI D6 D7: BNE D7 D8: BPL D8 D9: BVC D9 D10: BVS D10 D11: BRA D11 D12: BRL D12 dcb 0 Data: dcb 0x90 dcb 0xFE dcb 0x90 dcb 0xFE dcb 0xB0 dcb 0xFE dcb 0xB0 dcb 0xFE dcb 0xF0 dcb 0xFE dcb 0x30 dcb 0xFE dcb 0xD0 dcb 0xFE dcb 0x10 dcb 0xFE dcb 0x50 dcb 0xFE dcb 0x70 dcb 0xFE dcb 0x80 dcb 0xFE dcb 0x82 dcb 0xFD dcb 0xFF dcb 0x00 Test: ldx #24 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: } if (i) goto Fail; printf ("Passed Conformance Test 25.0.19\n"); return; Fail: printf ("Failed Conformance Test 25.0.19\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.2.CC b/Tests/Conformance/C25.0.2.CC new file mode 100755 index 0000000..2905951 --- /dev/null +++ b/Tests/Conformance/C25.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.2: Verification of code generation for AND instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: AND #0xF AND DP AND DP,X AND ABS AND ABS,X AND ABS,Y AND (DP),Y AND (DP,X) AND (DP) AND DP,S AND (DP,S),Y AND LONG AND LONG,X AND [DP] AND [DP],Y Data: dcb 0x29 dcb 0x0F dcb 0x00 dcb 0x25 dcb 0x02 dcb 0x35 dcb 0x02 dcb 0x2D dcb 0x00 dcb 0x08 dcb 0x3D dcb 0x00 dcb 0x08 dcb 0x39 dcb 0x00 dcb 0x08 dcb 0x31 dcb 0x02 dcb 0x21 dcb 0x02 dcb 0x32 dcb 0x02 dcb 0x23 dcb 0x02 dcb 0x33 dcb 0x02 dcb 0x2F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x3F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x27 dcb 0x02 dcb 0x37 dcb 0x02 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.2\n"); return; Fail: printf ("Failed Conformance Test 25.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.20.CC b/Tests/Conformance/C25.0.20.CC new file mode 100755 index 0000000..292f8f3 --- /dev/null +++ b/Tests/Conformance/C25.0.20.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.20: Verification of code generation for instructions */ /* whose only addressing mode is implied */ #include main () { int i = 0; asm { brl Test Code: CLC CLD CLI CLV DEX DEY INX INY NOP PHA PHP PLA PLP RTI RTS SEC SED SEI TAX TAY TSX TXA TXS TYA PHX PHY PLX PLY PHB PHD PHK PLB PLD RTL STP TCD TCS TDC TSC TXY TYX WAI XCE XBA Data: dcb 0x18 dcb 0xD8 dcb 0x58 dcb 0xB8 dcb 0xCA dcb 0x88 dcb 0xE8 dcb 0xC8 dcb 0xEA dcb 0x48 dcb 0x08 dcb 0x68 dcb 0x28 dcb 0x40 dcb 0x60 dcb 0x38 dcb 0xF8 dcb 0x78 dcb 0xAA dcb 0xA8 dcb 0xBA dcb 0x8A dcb 0x9A dcb 0x98 dcb 0xDA dcb 0x5A dcb 0xFA dcb 0x7A dcb 0x8B dcb 0x0B dcb 0x4B dcb 0xAB dcb 0x2B dcb 0x6B dcb 0xDB dcb 0x5B dcb 0x1B dcb 0x7B dcb 0x3B dcb 0x9B dcb 0xBB dcb 0xCB dcb 0xFB dcb 0xEB Test: ldx #42 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.20\n"); return; Fail: printf ("Failed Conformance Test 25.0.20\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.21.CC b/Tests/Conformance/C25.0.21.CC new file mode 100755 index 0000000..1270775 --- /dev/null +++ b/Tests/Conformance/C25.0.21.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.21: Verification of code generation for STX, STY */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { brl Test Code: STX DP STX DP,Y STX ABS STY DP STY DP,X STY ABS Data: dcb 0x86 dcb 0x02 dcb 0x96 dcb 0x02 dcb 0x8E dcb 0x00 dcb 0x08 dcb 0x84 dcb 0x02 dcb 0x94 dcb 0x02 dcb 0x8C dcb 0x00 dcb 0x08 Test: ldx #12 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.21\n"); return; Fail: printf ("Failed Conformance Test 25.0.21\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.22.CC b/Tests/Conformance/C25.0.22.CC new file mode 100755 index 0000000..4c19ef1 --- /dev/null +++ b/Tests/Conformance/C25.0.22.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.22: Verification of code generation for BRK, COP, */ /* MVN, MVP, PEA, PEI, PER, REP, SEP, TRB, and */ /* TSB instructions. */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { brl Test Code: BRK 0 BRK DP COP DP MVN DP,DP MVP DP,DP PEA ABS PEI DP PER Data REP #0xF SEP #0xF TRB DP TRB ABS TSB DP TSB ABS Data: dcb 0x00 dcb 0x00 dcb 0x00 dcb 0x02 dcb 0x02 dcb 0x02 dcb 0x54 dcb 0x00 dcb 0x00 dcb 0x44 dcb 0x00 dcb 0x00 dcb 0xF4 dcb 0x00 dcb 0x08 dcb 0xD4 dcb 0x02 dcb 0x62 dcb 0x0E dcb 0x00 dcb 0xC2 dcb 0x0F dcb 0xE2 dcb 0x0F dcb 0x14 dcb 0x02 dcb 0x1C dcb 0x00 dcb 0x08 dcb 0x04 dcb 0x02 dcb 0x0C dcb 0x00 dcb 0x08 Test: ldx #32 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.22\n"); return; Fail: printf ("Failed Conformance Test 25.0.22\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.23.CC b/Tests/Conformance/C25.0.23.CC new file mode 100755 index 0000000..8be8a2a --- /dev/null +++ b/Tests/Conformance/C25.0.23.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.23: Verification of code generation for STZ instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #include main () { int i = 0; asm { bra Test Code: STZ DP STZ DP,X STZ ABS STZ ABS,X Data: dcb 0x64 dcb 0x02 dcb 0x74 dcb 0x02 dcb 0x9C dcb 0x00 dcb 0x08 dcb 0x9E dcb 0x00 dcb 0x08 Test: ldx #8 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.23\n"); return; Fail: printf ("Failed Conformance Test 25.0.23\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.24.CC b/Tests/Conformance/C25.0.24.CC new file mode 100755 index 0000000..5c717ec --- /dev/null +++ b/Tests/Conformance/C25.0.24.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.24: Verification of code generation for jump */ /* instructions */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: JMP ABS JMP (ABS) JMP (ABS,X) JMP LONG JMP [ABS] JSR ABS JSR (ABS,X) JSL LONG Data: dcb 0x4C dcb 0x00 dcb 0x08 dcb 0x6C dcb 0x00 dcb 0x08 dcb 0x7C dcb 0x00 dcb 0x08 dcb 0x5C dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xDC dcb 0x00 dcb 0x08 dcb 0x20 dcb 0x00 dcb 0x08 dcb 0xFC dcb 0x00 dcb 0x08 dcb 0x22 dcb 0x56 dcb 0x34 dcb 0x12 Test: ldx #24 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.24\n"); return; Fail: printf ("Failed Conformance Test 25.0.24\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.25.CC b/Tests/Conformance/C25.0.25.CC new file mode 100755 index 0000000..d82491a --- /dev/null +++ b/Tests/Conformance/C25.0.25.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.25: Verification of code generation for upper and */ /* lower limits of all addressing modes */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: ADC 0x0 ADC 0xFF LDA 0x0,X LDA 0xFF,X LDX 0x0,Y LDX 0xFF,Y ROR |0x0000 ROR 0xFFFF ROL |0x0000,X ROL 0xFFFF,X STA |0x0000,Y STA 0xFFFF,Y JMP (|0x0000) JMP (0xFFFF) ORA (0x0),Y ORA (0xFF),Y CMP (0x0,X) CMP (0xFF,X) BEQ LBL4 LBL4: BEQ LBL4 AND (0x0) AND (0xFF) JMP (|0x0000,X) JMP (0xFFFF,X) SBC 0x0,S SBC 0xFF,S ADC (0x0,S),Y ADC (0xFF,S),Y AND >0x000000 AND 0xFFFFFF CMP >0x000000,X CMP 0xFFFFFF,X EOR [0x0] EOR [0xFF] LDA [0x0],Y LDA [0xFF],Y JMP [|0x0] JMP [0xFFFF] BRL LBL5 LBL5: BRL LBL5 Data: dcb 0x65 dcb 0x00 dcb 0x65 dcb 0xFF dcb 0xB5 dcb 0x00 dcb 0xB5 dcb 0xFF dcb 0xB6 dcb 0x00 dcb 0xB6 dcb 0xFF dcb 0x6E dcb 0x00 dcb 0x00 dcb 0x6E dcb 0xFF dcb 0xFF dcb 0x3E dcb 0x00 dcb 0x00 dcb 0x3E dcb 0xFF dcb 0xFF dcb 0x99 dcb 0x00 dcb 0x00 dcb 0x99 dcb 0xFF dcb 0xFF dcb 0x6C dcb 0x00 dcb 0x00 dcb 0x6C dcb 0xFF dcb 0xFF dcb 0x11 dcb 0x00 dcb 0x11 dcb 0xFF dcb 0xC1 dcb 0x00 dcb 0xC1 dcb 0xFF dcb 0xF0 dcb 0x00 dcb 0xF0 dcb 0xFE dcb 0x32 dcb 0x00 dcb 0x32 dcb 0xFF dcb 0x7C dcb 0x00 dcb 0x00 dcb 0x7C dcb 0xFF dcb 0xFF dcb 0xE3 dcb 0x00 dcb 0xE3 dcb 0xFF dcb 0x73 dcb 0x00 dcb 0x73 dcb 0xFF dcb 0x2F dcb 0x00 dcb 0x00 dcb 0x00 dcb 0x2F dcb 0xFF dcb 0xFF dcb 0xFF dcb 0xDF dcb 0x00 dcb 0x00 dcb 0x00 dcb 0xDF dcb 0xFF dcb 0xFF dcb 0xFF dcb 0x47 dcb 0x00 dcb 0x47 dcb 0xFF dcb 0xB7 dcb 0x00 dcb 0xB7 dcb 0xFF dcb 0xDC dcb 0x00 dcb 0x00 dcb 0xDC dcb 0xFF dcb 0xFF dcb 0x82 dcb 0x00 dcb 0x00 dcb 0x82 dcb 0xFD dcb 0xFF Test: ldx #100 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.25\n"); return; Fail: printf ("Failed Conformance Test 25.0.25\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.26.CC b/Tests/Conformance/C25.0.26.CC new file mode 100755 index 0000000..2814602 --- /dev/null +++ b/Tests/Conformance/C25.0.26.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.26: Make sure static variabes can be used */ #include static int j; void main(void) { static int i; asm { lda i sta j } printf ("Passed Conformance Test 25.0.26\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.3.CC b/Tests/Conformance/C25.0.3.CC new file mode 100755 index 0000000..9458272 --- /dev/null +++ b/Tests/Conformance/C25.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.3: Verification of code generation for CMP instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: CMP #0xF CMP DP CMP DP,X CMP ABS CMP ABS,X CMP ABS,Y CMP (DP),Y CMP (DP,X) CMP (DP) CMP DP,S CMP (DP,S),Y CMP LONG CMP LONG,X CMP [DP] CMP [DP],Y Data: dcb 0xC9 dcb 0x0F dcb 0x00 dcb 0xC5 dcb 0x02 dcb 0xD5 dcb 0x02 dcb 0xCD dcb 0x00 dcb 0x08 dcb 0xDD dcb 0x00 dcb 0x08 dcb 0xD9 dcb 0x00 dcb 0x08 dcb 0xD1 dcb 0x02 dcb 0xC1 dcb 0x02 dcb 0xD2 dcb 0x02 dcb 0xC3 dcb 0x02 dcb 0xD3 dcb 0x02 dcb 0xCF dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xDF dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xC7 dcb 0x02 dcb 0xD7 dcb 0x02 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.3\n"); return; Fail: printf ("Failed Conformance Test 25.0.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.4.CC b/Tests/Conformance/C25.0.4.CC new file mode 100755 index 0000000..0f40bb7 --- /dev/null +++ b/Tests/Conformance/C25.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.4: Verification of code generation for EOR instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: EOR #0xF EOR DP EOR DP,X EOR ABS EOR ABS,X EOR ABS,Y EOR (DP),Y EOR (DP,X) EOR (DP) EOR DP,S EOR (DP,S),Y EOR LONG EOR LONG,X EOR [DP] EOR [DP],Y Data: dcb 0x49 dcb 0x0F dcb 0x00 dcb 0x45 dcb 0x02 dcb 0x55 dcb 0x02 dcb 0x4D dcb 0x00 dcb 0x08 dcb 0x5D dcb 0x00 dcb 0x08 dcb 0x59 dcb 0x00 dcb 0x08 dcb 0x51 dcb 0x02 dcb 0x41 dcb 0x02 dcb 0x52 dcb 0x02 dcb 0x43 dcb 0x02 dcb 0x53 dcb 0x02 dcb 0x4F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x5F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x47 dcb 0x02 dcb 0x57 dcb 0x02 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.4\n"); return; Fail: printf ("Failed Conformance Test 25.0.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.5.CC b/Tests/Conformance/C25.0.5.CC new file mode 100755 index 0000000..e638aac --- /dev/null +++ b/Tests/Conformance/C25.0.5.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.5: Verification of code generation for LDA instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: LDA #0xF LDA DP LDA DP,X LDA ABS LDA ABS,X LDA ABS,Y LDA (DP),Y LDA (DP,X) LDA (DP) LDA DP,S LDA (DP,S),Y LDA LONG LDA LONG,X LDA [DP] LDA [DP],Y Data: dcb 0xA9 dcb 0x0F dcb 0x00 dcb 0xA5 dcb 0x02 dcb 0xB5 dcb 0x02 dcb 0xAD dcb 0x00 dcb 0x08 dcb 0xBD dcb 0x00 dcb 0x08 dcb 0xB9 dcb 0x00 dcb 0x08 dcb 0xB1 dcb 0x02 dcb 0xA1 dcb 0x02 dcb 0xB2 dcb 0x02 dcb 0xA3 dcb 0x02 dcb 0xB3 dcb 0x02 dcb 0xAF dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xBF dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xA7 dcb 0x02 dcb 0xB7 dcb 0x02 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.5\n"); return; Fail: printf ("Failed Conformance Test 25.0.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.6.CC b/Tests/Conformance/C25.0.6.CC new file mode 100755 index 0000000..1240c24 --- /dev/null +++ b/Tests/Conformance/C25.0.6.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.6: Verification of code generation for SBC instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: SBC #0xF SBC DP SBC DP,X SBC ABS SBC ABS,X SBC ABS,Y SBC (DP),Y SBC (DP,X) SBC (DP) SBC DP,S SBC (DP,S),Y SBC LONG SBC LONG,X SBC [DP] SBC [DP],Y Data: dcb 0xE9 dcb 0x0F dcb 0x00 dcb 0xE5 dcb 0x02 dcb 0xF5 dcb 0x02 dcb 0xED dcb 0x00 dcb 0x08 dcb 0xFD dcb 0x00 dcb 0x08 dcb 0xF9 dcb 0x00 dcb 0x08 dcb 0xF1 dcb 0x02 dcb 0xE1 dcb 0x02 dcb 0xF2 dcb 0x02 dcb 0xE3 dcb 0x02 dcb 0xF3 dcb 0x02 dcb 0xEF dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xFF dcb 0x56 dcb 0x34 dcb 0x12 dcb 0xE7 dcb 0x02 dcb 0xF7 dcb 0x02 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.6\n"); return; Fail: printf ("Failed Conformance Test 25.0.6\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.7.CC b/Tests/Conformance/C25.0.7.CC new file mode 100755 index 0000000..7a0c0e6 --- /dev/null +++ b/Tests/Conformance/C25.0.7.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.7: Verification of code generation for STA instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: STA DP STA DP,X STA ABS STA ABS,X STA ABS,Y STA (DP),Y STA (DP,X) STA (DP) STA DP,S STA (DP,S),Y STA LONG STA LONG,X STA [DP] STA [DP],Y dcb 0 Data: dcb 0x85 dcb 0x02 dcb 0x95 dcb 0x02 dcb 0x8D dcb 0x00 dcb 0x08 dcb 0x9D dcb 0x00 dcb 0x08 dcb 0x99 dcb 0x00 dcb 0x08 dcb 0x91 dcb 0x02 dcb 0x81 dcb 0x02 dcb 0x92 dcb 0x02 dcb 0x83 dcb 0x02 dcb 0x93 dcb 0x02 dcb 0x8F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x9F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x87 dcb 0x02 dcb 0x97 dcb 0x02 dcb 0 Test: ldx #34 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.7\n"); return; Fail: printf ("Failed Conformance Test 25.0.7\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.8.CC b/Tests/Conformance/C25.0.8.CC new file mode 100755 index 0000000..5128b72 --- /dev/null +++ b/Tests/Conformance/C25.0.8.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.8: Verification of code generation for ASL instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: ASL A ASL DP ASL DP,X ASL ABS ASL ABS,X dcb 0 Data: dcb 0x0A dcb 0x06 dcb 0x02 dcb 0x16 dcb 0x02 dcb 0x0E dcb 0x00 dcb 0x08 dcb 0x1E dcb 0x00 dcb 0x08 dcb 0x00 Test: ldx #10 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.8\n"); return; Fail: printf ("Failed Conformance Test 25.0.8\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C25.0.9.CC b/Tests/Conformance/C25.0.9.CC new file mode 100755 index 0000000..5e0bcb2 --- /dev/null +++ b/Tests/Conformance/C25.0.9.CC @@ -0,0 +1 @@ +/* Conformance Test 25.0.9: Verification of code generation for ORA instruct */ #define DP 0x02 /* define 1, 2, & 3 byte addresses */ #define ABS 0x800 #define LONG 0x123456 #include main () { int i = 0; asm { brl Test Code: ORA #0x1234 ORA DP ORA DP,X ORA ABS ORA ABS,X ORA ABS,Y ORA (DP),Y ORA (DP,X) ORA (DP) ORA DP,S ORA (DP,S),Y ORA [DP] ORA [DP],Y ORA LONG ORA LONG,X Data: dcb 0x09 dcb 0x34 dcb 0x12 dcb 0x05 dcb 0x02 dcb 0x15 dcb 0x02 dcb 0x0D dcb 0x00 dcb 0x08 dcb 0x1D dcb 0x00 dcb 0x08 dcb 0x19 dcb 0x00 dcb 0x08 dcb 0x11 dcb 0x02 dcb 0x01 dcb 0x02 dcb 0x12 dcb 0x02 dcb 0x03 dcb 0x02 dcb 0x13 dcb 0x02 dcb 0x07 dcb 0x02 dcb 0x17 dcb 0x02 dcb 0x0F dcb 0x56 dcb 0x34 dcb 0x12 dcb 0x1F dcb 0x56 dcb 0x34 dcb 0x12 Test: ldx #36 Lbl1: lda Code,X cmp Data,X bne Err1 dex dex bpl Lbl1 bra Out Err1: inc i Out: nop } if (i) goto Fail; printf ("Passed Conformance Test 25.0.9\n"); return; Fail: printf ("Failed Conformance Test 25.0.9\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.0.1.CC b/Tests/Conformance/C3.3.0.1.CC new file mode 100755 index 0000000..064abc6 --- /dev/null +++ b/Tests/Conformance/C3.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.0.1: Ensure macro names are ignored in comments */ /* and string constants */ #define sum(x,y) x+y #define mult(x,y) x*y main () { char a[25]; int x, y; x = /* sum(4,7) */ 10; /* This should be ignored */ y = /* mult(3,5) */ 2 * 9; /* This should also be ignored */ if ((x != 10) || (y != 18)) goto Fail; strcpy (a, "sum(x,y) mult(a,b)"); /* should also be ignored */ if ((strcmp (a, "sum(x,y) mult(a,b)")) != 0) goto Fail; printf ("Passed Conformance Test 3.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 3.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.1.1.CC b/Tests/Conformance/C3.3.1.1.CC new file mode 100755 index 0000000..a4d51d5 --- /dev/null +++ b/Tests/Conformance/C3.3.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.1.1: Verification of simple macro definitions */ #define A_LONG_MACRO_NAME 7 * 3999 / 18 + count - digits; #define SUBSTITUTION a_variable #define EXPRESSION (3 + 21 / 6) #define STRING"This string was made for testing, and that's just what\ it does" #define LABEL Fail #define begin { #define end } #define pass_msg ("Passed Conformance Test 3.3.1.1\n"); #define letsSplit return main () begin long SUBSTITUTION; char string [] = STRING; int i, count, digits; if ((strcmp (string,"This string was made for testing, and that's \ just what it does")) != 0) goto Fail; a_variable = (long) (EXPRESSION); if (a_variable != 6) goto LABEL; count = 5; digits = 20; i = A_LONG_MACRO_NAME if (i != 1540) goto LABEL; printf pass_msg letsSplit; Fail: printf ("Failed Conformance Test 3.3.1.1\n"); end \ No newline at end of file diff --git a/Tests/Conformance/C3.3.2.1.CC b/Tests/Conformance/C3.3.2.1.CC new file mode 100755 index 0000000..3a4b19b --- /dev/null +++ b/Tests/Conformance/C3.3.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.2.1: Verification of macros with parameters */ #define subtract(x,y) x - y #define noParmsPass() printf ("Passed Conformance Test 3.3.2.1\n"); #define noParmsFail() printf ("Failed Conformance Test 3.3.2.1\n"); #define many_parms(a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x,y,z) \ a+b+c+d+e+f+g+h+i+j+k+l+m+n+o+p+q+r+s+t+u+v+w+x+y+z #define real float main () { double f1(), g1(); int i; long j; real x, y; i = subtract (3, 5); if (i != -2) goto Fail; x = 3.5e4; y = 2.8e0; j = subtract (((long) f1(x)), ((int) g1(y))); if (j != 69995) goto Fail; i = many_parms (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26); if (i != 351) goto Fail; noParmsPass () return; Fail: noParmsFail () } /**************************************************************************/ double f1 ( y ) real y; { return (y * 2.0); } /**************************************************************************/ double g1 ( x ) real x; { return (x / 0.5e+0); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.3.1.CC b/Tests/Conformance/C3.3.3.1.CC new file mode 100755 index 0000000..b806a77 --- /dev/null +++ b/Tests/Conformance/C3.3.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.3.1: Ensure correct macro expansion for nested */ /* macros and nested macro calls */ #define addMult(a,b,c) mult ( (add((a),(c))), (b) ) #define mult(x,y) (y) * (x) #define add(i,j) (i) + (j) main () { long i, j, k, m; i = 2; j = 3; k = 5; m = addMult (i, j, k); if (m != 21) goto Fail; m = addMult ( (mult (j,k)), (add (m,i)), 4 ); if (m != 437) goto Fail; j = add ( (mult (k,i)), (addMult ((m), (mult ((i), (add (m,m))) ), (k)))); if (j != 772626) goto Fail; printf ("Passed Conformance Test 3.3.3.1\n"); return; Fail: printf ("Failed Conformance Test 3.3.3.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.4.1.CC b/Tests/Conformance/C3.3.4.1.CC new file mode 100755 index 0000000..f9f86e5 --- /dev/null +++ b/Tests/Conformance/C3.3.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.4.1: Verification of ANSI C and ORCA/C predefined */ /* macros */ main () { int i, j; float x, y; char str[80], fname[20] = "C3.3.4.1.CC"; #line 10 if (__LINE__ != 11) goto Fail; strcpy(str, __FILE__); i = strlen(str)-strlen(fname); if ((strcmp (&str[i], fname)) != 0) goto Fail; if (__STDC__ == 0) goto Fail; if (__ORCAC__ != 1) goto Fail; printf ("Passed Conformance Test 3.3.4.1\n"); return; Fail: printf ("Failed Conformance Test 3.3.4.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.5.1.CC b/Tests/Conformance/C3.3.5.1.CC new file mode 100755 index 0000000..cac3c39 --- /dev/null +++ b/Tests/Conformance/C3.3.5.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.5.1: Verification of undefining/redefining macros */ #undef macroNotDefinedYet /* not an error to undefine an */ /* undefined macro */ #define macroNotDefinedYet 8 #define macroNotDefinedYet 8 /* allow only "benign" redefinition */ #undef macroNotDefinedYet /* without intervening #undef */ #define macroNotDefinedYet 23 /* allow infinite undefining and */ /* redefining */ #define A23__BD8 "These are the days" #undef A23__BD8 #define A23__BD8 27.3e5 #undef A23__BD8 #define A23__BD8 "Passed Conformance Test 3.3.5.1\n" main () { if (macroNotDefinedYet != 23) goto Fail; printf (A23__BD8); return; Fail: printf ("Failed Conformance Test 3.3.5.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.6.1.CC b/Tests/Conformance/C3.3.6.1.CC new file mode 100755 index 0000000..759bc5b --- /dev/null +++ b/Tests/Conformance/C3.3.6.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.6.1: Verify precedence setting with parentheses */ /* in macro expansions */ #define SQUARE1(x) x * x #define SQUARE2(x) (x) * (x) #define SQUARE3(x) ( (x) * (x) ) main () { float y; int i; y = 3.5; y = (int) SQUARE1 (y + 1); if (y != 7.5) goto Fail; y = (int) SQUARE2 (y + 1); if (y != 68.0) goto Fail; i = (int) SQUARE3 (y + 1); if (i != 4761) goto Fail; printf ("Passed Conformance Test 3.3.6.1\n"); return; Fail: printf ("Failed Conformance Test 3.3.6.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.8.1.CC b/Tests/Conformance/C3.3.8.1.CC new file mode 100755 index 0000000..bb3c771 --- /dev/null +++ b/Tests/Conformance/C3.3.8.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.8.1: Verification of converting tokens to strings */ /* within macros */ #define CnvToString1(a,b,c) "not a " #a " nor a c" #c " nor a m" #b\ " be me\n" #define CnvToString2(a,b,c) "a = " #a " b = " #b " c = "#c main () { char string1[] = CnvToString1 (5, 276.145, 0x7F); char string2[] = CnvToString2 (4, 3, 0); if ((strcmp (string1, "not a 5 nor a c0x7F nor a m276.145 be me\n")) != 0) goto Fail; if ((strcmp (string2, "a = 4 b = 3 c = 0")) != 0) goto Fail; printf ("Passed Conformance Test 3.3.8.1\n"); return; Fail: printf ("Failed Conformance Test 3.3.8.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.3.9.1.CC b/Tests/Conformance/C3.3.9.1.CC new file mode 100755 index 0000000..85071be --- /dev/null +++ b/Tests/Conformance/C3.3.9.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.3.9.1: Verification of token merging in macro */ /* expansions */ #define INCR(j,k) j##k main () { int x; x = 3; x = INCR (+, +) x; if (x != 4) goto Fail; printf ("Passed Conformance Test 3.3.9.1\n"); return; Fail: printf ("Failed Conformance Test 3.3.9.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.1.1.CC b/Tests/Conformance/C3.5.1.1.CC new file mode 100755 index 0000000..d791ffb --- /dev/null +++ b/Tests/Conformance/C3.5.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.1.1: Verification of #if constant expressions */ #define FIVE 5 #define SIX 6 #if 2 * 8 #if 4 / 3 #if 209 - 8 #if 32760 + 7 #if (5 == 5) #if (2 != 0) #define NUM1 (2*8) | (4/3) ^ (209-208) & (32760+7) #else #define NUM1 5 #endif #else #define NUM1 4 #endif #else #define NUM1 3 #endif #else #define NUM1 2 #endif #else #define NUM1 1 #endif #else #define NUM1 0 #endif #if (6 < 32767) #if (20004 <= 20004) #if (59876 > 59875) #if (671234 >= 671234) #if ((2) && (3)) #if ((0) || (1)) #define NUM2 2147 % 3 << 3 >> 2 #else #define NUM2 5 #endif #else #define NUM2 4 #endif #else #define NUM2 3 #endif #else #define NUM2 2 #endif #else #define NUM2 1 #endif #else #define NUM2 0 #endif #if (-32768) #if ~0x7e #if !0 #define NUM3 NUM1 ? NUM2 : 187 #else #define NUM3 2 #endif #else #define NUM3 1 #endif #else #define NUM3 0 #endif #if (defined(FIVE)) && (defined(SIX)) && (NUM1 == 0x10) && (NUM2 == 4)\ && (NUM3 == NUM2) main () { printf ("Passed Conformance Test 3.5.1.1\n"); } #else main () { printf ("Failed Conformance Test 3.5.1.1\n"); } #endif \ No newline at end of file diff --git a/Tests/Conformance/C3.5.1.2.CC b/Tests/Conformance/C3.5.1.2.CC new file mode 100755 index 0000000..c76d416 --- /dev/null +++ b/Tests/Conformance/C3.5.1.2.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.1.2: Verification of #if character constant expressions */ #define FIVE '5' #define SIX '6' #if '2' * '8' #if '4' / '3' #if 'A' - 'b' #if '\r' + '\f' #if ('p' == '\x70') #if ('\001' != 0) #define NUM1 ('2'*'8') | ('4'/'3') ^ ('A'-'b')\ & ('\r'+'\f') #else #define NUM1 5 #endif #else #define NUM1 4 #endif #else #define NUM1 3 #endif #else #define NUM1 2 #endif #else #define NUM1 1 #endif #else #define NUM1 0 #endif #if ('6' < '7') #if ('2' <= '2') #if ('8' > '7') #if ('0' >= '0') #if (('\n') && ('\003')) #if ((0) || ('d')) #define NUM2 'z' % '0' << '\01' >> '\x2' #else #define NUM2 5 #endif #else #define NUM2 4 #endif #else #define NUM2 3 #endif #else #define NUM2 2 #endif #else #define NUM2 1 #endif #else #define NUM2 0 #endif #if -('\x7f') #if ~('\0') #if !0 #define NUM3 NUM1 ? NUM2 : 187 #else #define NUM3 2 #endif #else #define NUM3 1 #endif #else #define NUM3 0 #endif #if (defined(FIVE)) && (defined(SIX)) && (NUM1 == 0xAF8) && (NUM2 == 13)\ && (NUM3 == NUM2) main () { printf ("Passed Conformance Test 3.5.1.2\n"); } #else main () { printf ("Failed Conformance Test 3.5.1.2\n"); } #endif \ No newline at end of file diff --git a/Tests/Conformance/C3.5.1.3.CC b/Tests/Conformance/C3.5.1.3.CC new file mode 100755 index 0000000..07484f7 --- /dev/null +++ b/Tests/Conformance/C3.5.1.3.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.1.3: Verify macro expansion in #if commands */ #define VAL1 1 #undef VAL1 #if !VAL1 /* VAL1 should be undefined, and so evaluate as 0 */ main () { printf ("Passed Conformance Test 3.5.1.3\n"); } #else main () { printf ("Failed Conformance Test 3.5.1.3\n"); } #endif \ No newline at end of file diff --git a/Tests/Conformance/C3.5.1.4.CC b/Tests/Conformance/C3.5.1.4.CC new file mode 100755 index 0000000..5f71873 --- /dev/null +++ b/Tests/Conformance/C3.5.1.4.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.1.4: Verification of macro expansions in #if */ /* commands */ #define ONE 1 #define TWO 2 #define THREE 3 #define FOUR 4 #define FIVE '5' #define SIX '6' #define SEVEN '7' #define EIGHT 8 #define NINE 9 #define ZERO 0 #if ONE * TWO #if SEVEN / ONE #if NINE - 8 #if '\r' + ZERO #if (FIVE == '\x35') #if ('\001' != ZERO) #define NUM1 (ONE*TWO) | (SEVEN/ONE) ^ (NINE-8)\ & ('\r'+ZERO) #else #define NUM1 5 #endif #else #define NUM1 4 #endif #else #define NUM1 3 #endif #else #define NUM1 2 #endif #else #define NUM1 1 #endif #else #define NUM1 0 #endif #if (THREE < '7') #if ('6' <= SIX) #if (EIGHT > 2) #if (FOUR >= 4) #if (('\n') && ('\003')) #if ((0) || ('d')) #define NUM2 NINE / ONE << THREE >> TWO #else #define NUM2 5 #endif #else #define NUM2 4 #endif #else #define NUM2 3 #endif #else #define NUM2 2 #endif #else #define NUM2 1 #endif #else #define NUM2 0 #endif #if -(3 * SEVEN) #if ~(SIX) #if !ZERO #define NUM3 NUM1 ? NUM2 : 187 #else #define NUM3 2 #endif #else #define NUM3 1 #endif #else #define NUM3 0 #endif #if (defined(FIVE)) && (defined(SIX)) && (NUM1 == 54) && (NUM2 == 18)\ && (NUM3 == NUM2) main () { printf ("Passed Conformance Test 3.5.1.4\n"); } #else main () { printf("%d %d %d\n", NUM1, NUM2, NUM3); printf ("Failed Conformance Test 3.5.1.4\n"); } #endif \ No newline at end of file diff --git a/Tests/Conformance/C3.5.1.5.CC b/Tests/Conformance/C3.5.1.5.CC new file mode 100755 index 0000000..fd0c1bd --- /dev/null +++ b/Tests/Conformance/C3.5.1.5.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.1.5: Ensure #if, #else with no lines to compile */ /* are not errors */ #if 5 #else #endif #if !0 #define TRUE 1 #else #endif #if 32767 #else #define FALSE 0 #endif #if defined(FALSE) #define fail 1 #else #define fail 0 #endif main () { if (TRUE != 1) goto Fail; if (fail) goto Fail; printf ("Passed Conformance Test 3.5.1.5\n"); return; Fail: printf ("Failed Conformance Test 3.5.1.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.2.1.CC b/Tests/Conformance/C3.5.2.1.CC new file mode 100755 index 0000000..0de3790 --- /dev/null +++ b/Tests/Conformance/C3.5.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.2.1: Verification of #elif command */ #if 0 # define MSG "Failed Conformance Test 3.5.2.1; location 1\n" #elif (5 - 5) # define MSG "Failed Conformance Test 3.5.2.1; location 2\n" #elif 1 # define MSG "Passed Conformance Test 3.5.2.1\n" #elif 2 # define MSG "Failed Conformance Test 3.5.2.1; location 3\n" #elif 3 # define MSG "Failed Conformance Test 3.5.2.1; location 4\n" #elif 4 # define MSG "Failed Conformance Test 3.5.2.1; location 5\n" #elif 5 # define MSG "Failed Conformance Test 3.5.2.1; location 6\n" #elif 6 # define MSG "Failed Conformance Test 3.5.2.1; location 7\n" #elif 7 # define MSG "Failed Conformance Test 3.5.2.1; location 8\n" #else # define MSG "Failed Conformance Test 3.5.2.1; location 9\n" #endif main () { printf (MSG); } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.2.2.CC b/Tests/Conformance/C3.5.2.2.CC new file mode 100755 index 0000000..32171d0 --- /dev/null +++ b/Tests/Conformance/C3.5.2.2.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.2.2: Verification of #elif command, using macro */ /* substitution */ #define MACRO1(x,y,z) ((x) + (y) * (z)) #define PASS "Passed Conformance Test 3.5.2.2\n" #define FAIL "Failed Conformance Test 3.5.2.2\n" #if MACRO1 (-6,2,3) # define MSG FAIL #elif MACRO1 (8,-4,2) # define MSG FAIL #elif MACRO1 (16,8,-2) # define MSG FAIL #elif MACRO1 (-10,-5,-2) # define MSG FAIL #elif MACRO1 (2,3,4) # define MSG PASS #elif MACRO1 (1,2,3) # define MSG FAIL #elif MACRO1 (2,3,4) # define MSG FAIL #elif MACRO1 (3,4,5) # define MSG FAIL #elif MACRO1 (4,5,6) # define MSG FAIL #elif MACRO1 (5,6,7) # define MSG FAIL #elif MACRO1 (6,7,8) # define MSG FAIL #elif MACRO1 (7,8,9) # define MSG FAIL #elif MACRO1 (4,2,-2) # define MSG FAIL #elif MACRO1 (0,0,0) # define MSG FAIL #elif MACRO1 (4,5,6) # define MSG FAIL #else # define MSG FAIL #endif main () { printf (MSG); } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.2.3.CC b/Tests/Conformance/C3.5.2.3.CC new file mode 100755 index 0000000..d57aacd --- /dev/null +++ b/Tests/Conformance/C3.5.2.3.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.2.3: Verification of nested #elif commands */ #define PASS "Passed Conformance Test 3.5.2.3\n" #define FAIL "Failed Conformance Test 3.5.2.3\n" main () { #if 1 #if 2 #if 0 printf (FAIL); #elif 0 printf (FAIL); #elif 32767 printf (PASS); #endif #elif 3 printf (FAIL); #elif 0 printf (FAIL); #else printf (FAIL); #endif #elif 5 printf (FAIL); #elif 6 printf (FAIL); #elif 7 printf (FAIL); #elif 8 printf (FAIL); #elif 0 printf (FAIL); #else printf (FAIL); #endif } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.2.4.CC b/Tests/Conformance/C3.5.2.4.CC new file mode 100755 index 0000000..32a7e4e --- /dev/null +++ b/Tests/Conformance/C3.5.2.4.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.2.4: Verification of nested #elif commands, using */ /* macro substitution */ #define PASS "Passed Conformance Test 3.5.2.4\n" #define FAIL "Failed Conformance Test 3.5.2.4\n" #define CALL1(a,b,c) ((a) - (b) * (c)) #define CALL2(x,y) ((x) || (y)) main () { #if CALL1 (6,2,3) #if CALL1 (8,2,4) #if CALL2 (0,0) printf (FAIL); #elif 0 printf (FAIL); #elif 32767 printf (FAIL); #endif #elif CALL1 (10,3,4) printf (FAIL); #elif CALL2 (7,0) printf (FAIL); #else printf (FAIL); #endif #elif CALL1 (12,4,3) printf (FAIL); #elif CALL2 ((5-(4+1)), 0) printf (FAIL); #elif CALL1 (16,4,4) printf (FAIL); #elif 0 printf (FAIL); #elif CALL1 (20,-10,-2) printf (FAIL); #else printf (PASS); #endif } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.3.1.CC b/Tests/Conformance/C3.5.3.1.CC new file mode 100755 index 0000000..8fcb34e --- /dev/null +++ b/Tests/Conformance/C3.5.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.3.1: Verification of #ifdef and #ifndef commands */ #define ONE 1 #define TWO 2 #define THREE 3 #define FOUR 4 #ifdef ONE #define COUNT1 1 #endif #ifdef TWO #define COUNT2 2 #endif #ifdef THREE #define COUNT3 3 #endif #ifdef FOUR #define COUNT4 4 #endif #undef ONE #undef TWO #undef THREE #undef FOUR #ifndef ONE #define COUNT5 5 #endif #ifndef TWO #define COUNT6 6 #endif #ifndef THREE #define COUNT7 7 #endif #ifndef FOUR #define COUNT8 8 #endif main () { int a; a = COUNT1 + COUNT2 + COUNT3 + COUNT4 + COUNT5 + COUNT6 + COUNT7 + COUNT8; if (a != 36) goto Fail; printf ("Passed Conformance Test 3.5.3.1\n"); return; Fail: printf ("Failed Conformance Test 3.5.3.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.4.1.CC b/Tests/Conformance/C3.5.4.1.CC new file mode 100755 index 0000000..fe288b6 --- /dev/null +++ b/Tests/Conformance/C3.5.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.4.1: Verification of #elif constant expressions */ #define FIVE 5 #define SIX 6 #if 0 #define NUM1 0 #elif 2 * 8 #define NUM1 2*8 #else #define NUM1 0 #endif #if 0 #define NUM2 0 #elif 4 / 3 #define NUM2 4/3 #endif #if 0 #define NUM3 0 #elif 209 - 8 #define NUM3 (209 - 8) #else #define NUM3 0 #endif #if 0 #define NUM4 0 #elif 32760 + 7 #define NUM4 ((32760) + (7)) #endif #if 0 #define NUM5 0 #elif (5 == 5) #define NUM5 5 == 5 #else #define NUM5 0 #endif #if 0 #define NUM6 0 #elif (2 != 0) #define NUM6 (2*8) | (4/3) ^ (209-208) & (32760+7) #else #define NUM6 0 #endif #if 0 #define NUM7 0 #elif (6 < 32767) #define NUM7 6 < 32767 #else #define NUM7 0 #endif #if 0 #define NUM8 0 #elif (20004 <= 20004) #define NUM8 (( 20004 <= 20004 )) #else #define NUM8 0 #endif #if 0 #define NUM9 0 #elif (59876 > 59875) #define NUM9 59876 > 59875 #endif #if 0 #define NUM10 0 #elif (671234 >= 671234) #define NUM10 671234 >= 671234 #else #define NUM10 0 #endif #if 0 #define NUM11 0 #elif ((2) && (3)) #define NUM11 2 && 3 #else #define NUM11 0 #endif #if 0 #define NUM12 0 #elif ((0) || (1)) #define NUM12 2147 % 3 << 3 >> 2 #else #define NUM12 0 #endif #if 0 #define NUM13 0 #elif (-32768) #define NUM13 (-(32768)) #else #define NUM13 0 #endif #if 0 #define NUM14 0 #elif ~0x7e #define NUM14 ~0x7E #else #define NUM14 0 #endif #if 0 #define NUM15 0 #elif !0 #define NUM15 NUM1 ? NUM2 : 187 #else #define NUM15 0 #endif main () { if ( ! ((FIVE == 5) && (1 == NUM10)) ) goto Fail; if (NUM1 != 16 ) goto Fail; if (NUM2 != 1 ) goto Fail; if (NUM3 != 201 ) goto Fail; if (NUM4 != 32767 ) goto Fail; if (NUM5 != 1 ) goto Fail; if (NUM6 != 0xB8 ) goto Fail; if (NUM7 != 1 ) goto Fail; if (NUM8 != 1 ) goto Fail; if (NUM9 != 1 ) goto Fail; if (NUM10 != 1 ) goto Fail; if (NUM11 != 1 ) goto Fail; if (NUM12 != 4 ) goto Fail; if (NUM13 != -32768) goto Fail; if (NUM14 != 0x81 ) goto Fail; if (NUM15 != 1 ) goto Fail; printf ("Passed Conformance Test 3.5.4.1\n"); return; Fail: printf ("Passed Conformance Test 3.5.4.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C3.5.4.2.CC b/Tests/Conformance/C3.5.4.2.CC new file mode 100755 index 0000000..8462c2b --- /dev/null +++ b/Tests/Conformance/C3.5.4.2.CC @@ -0,0 +1 @@ +/* Conformance Test 3.5.4.2: Verification of #elif character constant */ /* expressions */ #define FIVE '5' #define SIX '6' #if 0 #define NUM1 0 #elif '2' * '8' #define NUM1 '2' * '8' #else #define NUM1 0 #endif #if 0 #define NUM2 0 #elif '4' / '3' #define NUM2 '4' / '3' #else #define NUM2 0 #endif #if 0 #define NUM3 0 #elif 'b' - 'a' #define NUM3 'b' - 'a' #else #define NUM3 0 #endif #if 0 #define NUM4 0 #elif '\r' + '\f' #define NUM4 '\r' + '\f' #else #define NUM4 0 #endif #if 0 #define NUM5 0 #elif ('p' == '\x70') #define NUM5 (('\p') == '\x70') #else #define NUM5 0 #endif #if 0 #define NUM6 0 #elif ('\001' != 0) #define NUM6 ('2'*'8') | ('4'/'3') ^ ('A'-'b')\ & ('\r'+'\f') #else #define NUM6 0 #endif #if 0 #define NUM7 0 #elif ('6' < '7') #define NUM7 '6' < '7' #else #define NUM7 0 #endif #if 0 #define NUM8 0 #elif ('2' <= '2') #define NUM8 '2' <= '2' #else #define NUM8 0 #endif #if 0 #define NUM9 0 #elif ('8' > '7') #define NUM9 '8' > '7' #else #define NUM9 0 #endif #if 0 #define NUM10 0 #elif ('0' >= '0') #define NUM10 '0' >= '0' #else #define NUM10 0 #endif #if 0 #define NUM11 0 #elif (('\n') && ('\003')) #define NUM11 (('\n') && ('\003')) #else #define NUM11 0 #endif #if 0 #define NUM12 0 #elif ((0) || ('d')) #define NUM12 'z' % '0' << '\01' >> '\x2' #else #define NUM12 0 #endif #if 0 #define NUM13 0 #elif -('\x7f') #define NUM13 (-('\x7f')) #else #define NUM13 0 #endif #if 0 #define NUM14 0 #elif ~('\0') #define NUM14 ~'\0' #else #define NUM14 0 #endif #if 0 #define NUM15 0 #elif !0 #define NUM15 NUM1 ? NUM2 : 187 #else #define NUM15 0 #endif #if 0 #elif (defined(FIVE)) && (defined(SIX)) && (NUM1 == 0xAF0) && (NUM2 == 1)\ && (NUM3 == NUM2) main () { if (NUM1 != 2800 ) goto Fail; if (NUM2 != 1 ) goto Fail; if (NUM3 != 1 ) goto Fail; if (NUM4 != 25 ) goto Fail; if (NUM5 != 1 ) goto Fail; if ((NUM6) != 0xAF8 ) goto Fail; if (NUM7 != 1 ) goto Fail; if (NUM8 != 1 ) goto Fail; if (NUM9 != 1 ) goto Fail; if (NUM10 != 1 ) goto Fail; if (NUM11 != 1 ) goto Fail; if (NUM12 != 13 ) goto Fail; if (NUM13 != -127 ) goto Fail; if (NUM14 != -1 ) goto Fail; if ((NUM15) != 1 ) goto Fail; printf ("Passed Conformance Test 3.5.4.2\n"); return; Fail: printf ("Failed Conformance Test 3.5.4.2; location 1\n"); } #else main () { printf ("Failed Conformance Test 3.5.4.2; location 2\n"); } #endif \ No newline at end of file diff --git a/Tests/Conformance/C4.2.1.1.CC b/Tests/Conformance/C4.2.1.1.CC new file mode 100755 index 0000000..5f680c0 --- /dev/null +++ b/Tests/Conformance/C4.2.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.2.1.1: Test scoping of identifiers */ /* Global declarations of all different identifier types in C. */ /* Each identifier should be available through the end of the source file. */ #include #define MAC_NAME1 10 /* macro name */ typedef int *intPtr; /* user-defined type */ char F1 (int x, int y); /* function name */ int i; /* variable */ struct ComplexNum { float real; /* type tag name */ float imag; }; /* and struct fields */ union LongOrShort { long longNum; /* type tag name */ int shortNum; }; /* and union fields */ enum flowers { rose, iris, carnation }; /* type tag name */ /* and enum const */ main () { char ch; int m; intPtr k; struct ComplexNum c, d; union LongOrShort z; enum flowers f; m = 3; k = &m; if (*k != 3) goto Fail; c.real = 5.1; c.imag = 2.0; d = c; if ((fabs(d.real - 5.1) > 0.00001) || (fabs(d.imag - 2.0) > 0.00001)) goto Fail; z.longNum = 5; if (z.shortNum != 5) /* don't ever do this in real life! */ goto Fail; f = carnation; if (f != 2) goto Fail; i = MAC_NAME1; if (i != 10) goto Fail; ch = F1 (3, i); if (ch != '\r') goto Fail; printf ("Passed Conformance Test 4.2.1.1\n"); return; printf ("This code can never be reached !!!\n"); Fail: printf ("Failed Conformance Test 4.2.1.1\n"); return; printf ("Nor can this code ever be reached !!!\n"); } /****************************************************************************/ char F1 (int x, int y) { int m; intPtr k; struct ComplexNum c, *d; union LongOrShort z; enum flowers f; m = 5; k = &m; if (*k != 5) goto Err1; c.real = 18.7; c.imag = 23.5; d = &c; if ((fabs(d->real - 18.7) > 0.00001) || (fabs(d->imag - 23.5) > 0.00001)) goto Err2; z.longNum = 0x7FE5; if (z.shortNum != 0x7fe5) /* don't ever do this in real life! */ goto Err3; #define MAC_NAME2 11 f = iris; if (f != 1) goto Fail; i = MAC_NAME2; if (i != 11) goto Fail; return (x + y); Err1: return (1); Err2: return (2); Err3: return (3); Fail: return (4); } \ No newline at end of file diff --git a/Tests/Conformance/C4.2.2.1.CC b/Tests/Conformance/C4.2.2.1.CC new file mode 100755 index 0000000..ffb25d8 --- /dev/null +++ b/Tests/Conformance/C4.2.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.2.2.1: Verify correct identifier "hiding" */ /* Global declarations of all different identifier types in C. */ #include typedef int *numPtr; /* user-defined type */ float f; /* variables */ double ch; struct aRecord { int value1; /* type tag name */ int value2; }; /* and struct fields */ union variantRec { long longNum; /* type tag name */ int shortNum; }; /* and union fields */ enum flowers { rose, iris, carnation }; /* type tag name */ /* and enum const */ int DoubleCheck (void); /* function names */ /******************************************************************************/ int i (char ch) { return ch; } /******************************************************************************/ main () { int i; typedef float *numPtr; /* redefine the global types */ numPtr f; struct variantRec { long longNum; int shortNum; }; enum aRecord { rec1, rec2, rec3 }; union flowers { int x; long y; }; struct variantRec r1, *r2; enum aRecord x, y; union flowers longNum, Rose; float fp; ch = 6.0; if (fabs(ch - 6.0) > 0.00001) goto Fail; fp = 3.1; f = &fp; if (fabs(*f - 3.1) > 0.00001) goto Fail; r1.longNum = 10; r1.shortNum = 12; r2 = &r1; if ((r2->longNum != 10) || (r2->shortNum != 12)) goto Fail; x = rec1; y = rec3; if ((x != 0) || (y != 2)) goto Fail; longNum.x = 89; longNum.y = 101; Rose = longNum; if (Rose.y != 101) goto Fail; i = DoubleCheck(); if (i != 0) goto Fail; printf ("Passed Conformance Test 4.2.2.1\n"); return; Fail: printf ("Failed Conformance Test 4.2.2.1\n"); } /******************************************************************************/ int DoubleCheck (void) { numPtr k; int f; struct aRecord R1, *R2; union variantRec value1, value2; enum flowers dahlia; f = i ('a'); if (f != 0x61) goto Fail; f = 45; k = &f; if (*k != 45) goto Fail; R2 = &R1; R2->value1 = 18; (*R2).value2 = 27; if ((R1.value1 != 18) || (R1.value2 != 27)) goto Fail; value1.shortNum = 111; value2 = value1; if (value2.shortNum != 111) goto Fail; dahlia = carnation; if (dahlia != 2) goto Fail; return 0; Fail: return 211; } \ No newline at end of file diff --git a/Tests/Conformance/C4.2.4.1.CC b/Tests/Conformance/C4.2.4.1.CC new file mode 100755 index 0000000..8066103 --- /dev/null +++ b/Tests/Conformance/C4.2.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.2.4.1: Ensure the same names in different overloading */ /* classes are allowed */ struct rect { int h1; /* struct, union, enum type tags */ int v1; /* struct/union components */ int h2; int v2; }; union longOrShort { int first; long second; }; enum repeats { h1, v1, h2, v2, first, second }; /* all others: variables, */ /* functions, typedefs, */ /* enumeration constants*/ main () { int rect; /* can give variables same */ double longOrShort; /* names as labels, tags,*/ float repeats; /* or components */ int label [10]; union longOrShort first; enum repeats r; enum colors { red, black, green }; struct person { char name [20]; char address [50]; }; union floatOrDouble { float red; double green; }; int Label2 (void); /* can give functions same */ char person (int i); /* names as labels, tags,*/ float name (void); /* or components */ typedef int Label3; /* can give typedefs same */ typedef struct person floatOrDouble; /* names as labels, tags,*/ typedef short colors; /* or components */ typedef float address; Label3 i; floatOrDouble x; colors j; address z; rect = 8; if (rect != 8) goto label; longOrShort = 3.5; if (longOrShort != 3.5) goto Label3; repeats = (float) 2; if (repeats != 2.0) goto label; for (i = 0; i < 10; i++) label [i] = i; for (i = 9; i >= 0; i--) if (label [i] != i) goto label; first.first = 10; if (first.first != (9+1)) goto Label2; r = second; if (r != 5) goto Label2; strcpy (x.name, "Barbara"); if ((strcmp (x.name, "Barbara")) != 0) goto label; j = (int) person (6); if (j != 0x36) goto Label2; j = Label2 (); if (j != 5) goto Label2; z = name (); if (z != 1.0) goto label; printf ("Passed Conformance Test 4.2.4.1\n"); return; label: ; Label2: ; Label3: printf ("Failed Conformance Test 4.2.4.1\n"); } /******************************************************************************/ int Label2 (void) { return 5; } /******************************************************************************/ char person (int i) { return (i + 0x30); } /******************************************************************************/ float name (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Conformance/C4.2.5.1.CC b/Tests/Conformance/C4.2.5.1.CC new file mode 100755 index 0000000..6b9ca69 --- /dev/null +++ b/Tests/Conformance/C4.2.5.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.2.5.1: Verification of duplicate extern references */ int a; extern float F1 (int x, int y); main () { extern int a; extern float F1 (int x, int y); float x; extern extended G1 (void); a = (int) F1 (2, 3); if (a != 5) goto Fail; x = (float) G1 (); if (x != 10.0) goto Fail; printf ("Passed Conformance Test 4.2.5.1\n"); return; Fail: printf ("Failed Conformance Test 4.2.5.1\n"); } /*****************************************************************************/ extended G1 (void) { extern float F1 (int x, int y); extern int a; return (F1 (a, 5)); } /*****************************************************************************/ float F1 (int x, int y) { extern extended G1 (void); extern int a; return (float) (x + y); } \ No newline at end of file diff --git a/Tests/Conformance/C4.3.0.1.CC b/Tests/Conformance/C4.3.0.1.CC new file mode 100755 index 0000000..cccae3b --- /dev/null +++ b/Tests/Conformance/C4.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.3.0.1: Verification of auto, register, and static */ /* storage classes */ static long L1 (register int a1, float x1); /* test forward referencing */ /* at top level */ static extended ext = 3.678; /* ensure static variables */ static int j = 2; /* initialized correctly */ static int i; /* should automatically be */ /* set to zero */ main () { static void V1 (void); /* test forward referencing within */ /* function */ long LL = 3; if (ext != 3.678) goto Fail; { auto i = 10; /* this i hides top-level i */ for (; i < 15; i++) { V1 (); switch (i) { case 10: if (j != 3) goto Fail; break; case 11: if (j != 4) goto Fail; break; case 12: if (j != 5) goto Fail; break; case 13: if (j != 6) goto Fail; break; case 14: if (j != 7) goto Fail; break; default: goto Fail; break; } /* end switch */ } /* end for */ } /* end inner block */ if (i != 5) /* top-level i */ goto Fail; for (i = 0; i < 7; i++) /* L0 should be init. to 10 with each */ { /* pass through the for loop; F0 */ auto int L0 = 10; /* should be initialized once */ static float F0 = 1.0; LL = L1 (L0, F0); if (LL) goto Fail; F0 += 1.0; if (F0 == 3.0) break; } if (i != 1) /* test that F0 was not reset */ goto Fail; printf ("Passed Conformance Test 4.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 4.3.0.1\n"); } /******************************************************************************/ static long L1 (register int a1, float x1) /* ensure classification as */ { /* register doesn't affect */ /* value of parameter */ if (a1 != 10) /* a1 should be 10 each time called */ return 1; else return 0; } /******************************************************************************/ static void V1 (void) { ++i; j++; /* ensure i, j are visible */ } \ No newline at end of file diff --git a/Tests/Conformance/C4.3.0.2.CC b/Tests/Conformance/C4.3.0.2.CC new file mode 100755 index 0000000..6d40b52 --- /dev/null +++ b/Tests/Conformance/C4.3.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.3.0.2: Check uniqueness of static variables */ static int var; int sub1(void) { static int var; var = 2; { static int var; var = 3; if (var != 3) return 1; } if (var != 2) return 1; return 0; } int sub2(void) { static int var; var = 2; { static int var; var = 3; if (var != 3) return 1; } if (var != 2) return 1; return 0; } void main (void) { var = 1; if (sub1()) goto Fail; if (sub2()) goto Fail; if (var != 1) goto Fail; printf ("Passed Conformance Test 4.3.0.2\n"); return; Fail: printf ("Failed Conformance Test 4.3.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.4.2.1.CC b/Tests/Conformance/C4.4.2.1.CC new file mode 100755 index 0000000..ef8e30c --- /dev/null +++ b/Tests/Conformance/C4.4.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.4.2.1: Ensure compile accepts missing declarators */ struct {int a; /* can't use it, but it's legal */ float x;}; int ; /* nothing declared, but it's legal */ static enum E {a, b, c}; /* storage class ignored */ main () { struct {double d; short s;}; extended; extern union U {int i; long l;}; printf ("Passed Conformance Test 4.4.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.2.1.CC b/Tests/Conformance/C4.5.2.1.CC new file mode 100755 index 0000000..4b3b409 --- /dev/null +++ b/Tests/Conformance/C4.5.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.2.1: Verification of pointer declarators for local */ /* data */ #include main () { int *intPtr, i; /* pointers to all the basic types */ long *longPtr, L; unsigned int *uintPtr, ui; unsigned long *ulongPtr, ulong; comp *compPtr, cmp; char *charPtr, ch; float *floatPtr, fl; double *doublePtr, dbl; extended *extPtr, ext; /* pointers to conglomerate types */ struct s { int a; long L; } *structPtr, s; enum colors { red, black, green } *colorPtr, color; union longOrShort { int first; long second; } *unionPtr, un; intPtr = &i; i = 3; if (*intPtr != 3) goto Fail; longPtr = &L; L = 32769; if (*longPtr != 32769) goto Fail; uintPtr = &ui; ui = 65535; if (*uintPtr != 65535) goto Fail; ulongPtr = &ulong; ulong = 4294967295ul; if (*ulongPtr != 4294967295ul) goto Fail; compPtr = &cmp; cmp = 4294967295ul; if (*compPtr != 4294967295ul) goto Fail; charPtr = &ch; ch = 'A'; if (*charPtr != 'A') goto Fail; floatPtr = &fl; fl = 123.456; if (fabs(*floatPtr - 123.456) > 0.00001) goto Fail; doublePtr = &dbl; dbl = 0.0; if (*doublePtr != 0.0) goto Fail; extPtr = &ext; ext = 12.3e20; if (*extPtr != 123.0E19) goto Fail; structPtr = &s; s.a = 32767; s.L = 2147483647; if ((structPtr->L != 2147483647) || (structPtr->a != 32767)) goto Fail; intPtr = &(s.a); if (*intPtr != 32767) goto Fail; longPtr = &(s.L); if (*longPtr != 2147483647) goto Fail; colorPtr = &color; color = black; if (*colorPtr != black) goto Fail; unionPtr = &un; un.first = 12; if (unionPtr->first != 12) goto Fail; un.second = 2147483646; if (unionPtr->second != 2147483646) goto Fail; printf ("Passed Conformance Test 4.5.2.1\n"); return; Fail: printf ("Failed Conformance Test 4.5.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.2.2.CC b/Tests/Conformance/C4.5.2.2.CC new file mode 100755 index 0000000..26c7a41 --- /dev/null +++ b/Tests/Conformance/C4.5.2.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.2.2: Verification of pointer declarators for local */ /* data using the typedef storage class */ #include main () { /* pointers to all the basic types */ typedef int *intPtr; intPtr iPtr; int i; typedef long *longPtr; longPtr lPtr; long L; typedef unsigned int *uintPtr; uintPtr uiPtr; unsigned int ui; typedef unsigned long *ulongPtr; ulongPtr ulPtr; unsigned long ulong; typedef comp *compPtr; compPtr cmpPtr; comp cmp; typedef char *charPtr; charPtr chPtr; char ch; typedef float *floatPtr; floatPtr flPtr; float fl; typedef double *doublePtr; doublePtr dblPtr; double dbl; typedef extended *extPtr; extPtr ePtr; extended ext; /* pointers to conglomerate types */ struct s { int a; long L; }; typedef struct s *structPtr; structPtr sPtr; struct s s; enum colors { red, black, green }; typedef enum colors *colorPtr; colorPtr colPtr; enum colors color; union longOrShort { int first; long second; }; typedef union longOrShort *unionPtr; unionPtr unPtr; union longOrShort un; iPtr = &i; i = 3; if (*iPtr != 3) goto Fail; lPtr = &L; L = 32769; if (*lPtr != 32769) goto Fail; uiPtr = &ui; ui = 65535; if (*uiPtr != 65535) goto Fail; ulPtr = &ulong; ulong = 4294967295ul; if (*ulPtr != 4294967295ul) goto Fail; cmpPtr = &cmp; cmp = 4294967295ul; if (*cmpPtr != 4294967295ul) goto Fail; chPtr = &ch; ch = 'A'; if (*chPtr != 'A') goto Fail; flPtr = &fl; fl = 123.456; if (fabs(*flPtr - 123.456) > 0.00001) goto Fail; dblPtr = &dbl; dbl = 0.0; if (*dblPtr != 0.0) goto Fail; ePtr = &ext; ext = 12.3e20; if (fabs(*ePtr - 123.0E19) >0.00001) goto Fail; sPtr = &s; s.a = 32767; s.L = 2147483647; if ((sPtr->L != 2147483647) || (sPtr->a != 32767)) goto Fail; iPtr = &(s.a); if (*iPtr != 32767) goto Fail; lPtr = &(s.L); if (*lPtr != 2147483647) goto Fail; colPtr = &color; color = black; if (*colPtr != black) goto Fail; unPtr = &un; un.first = 12; if (unPtr->first != 12) goto Fail; un.second = 2147483646; if (unPtr->second != 2147483646) goto Fail; printf ("Passed Conformance Test 4.5.2.2\n"); return; Fail: printf ("Failed Conformance Test 4.5.2.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.2.3.CC b/Tests/Conformance/C4.5.2.3.CC new file mode 100755 index 0000000..ad02074 --- /dev/null +++ b/Tests/Conformance/C4.5.2.3.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.2.3: Verification of pointer declarators for static */ /* data */ #include /* pointers to all the basic types */ static int *intPtr, i; static long *longPtr, L; static unsigned int *uintPtr, ui; static unsigned long *ulongPtr, ulong; static comp *compPtr, cmp; static char *charPtr, ch; static float *floatPtr, fl; static double *doublePtr, dbl; static extended *extPtr, ext; /* pointers to conglomerate types */ static struct s { int a; long L; } *structPtr, s; static enum colors { red, black, green } *colorPtr, color; static union longOrShort { int first; long second; } *unionPtr, un; main () { void F1 (void); F1(); } /******************************************************************************/ void F1 (void) { intPtr = &i; i = 3; if (*intPtr != 3) goto Fail; longPtr = &L; L = 32769; if (*longPtr != 32769) goto Fail; uintPtr = &ui; ui = 65535; if (*uintPtr != 65535) goto Fail; ulongPtr = &ulong; ulong = 4294967295ul; if (*ulongPtr != 4294967295ul) goto Fail; compPtr = &cmp; cmp = 4294967295ul; if (*compPtr != 4294967295ul) goto Fail; charPtr = &ch; ch = 'A'; if (*charPtr != 'A') goto Fail; floatPtr = &fl; fl = 123.456; if (fabs(*floatPtr - 123.456) > 0.00001) goto Fail; doublePtr = &dbl; dbl = 0.0; if (fabs(*doublePtr - 0.0) > 0.00001) goto Fail; extPtr = &ext; ext = 12.3e20; if (fabs(*extPtr - 123.0E19) > 0.00001) goto Fail; structPtr = &s; s.a = 32767; s.L = 2147483647; if ((structPtr->L != 2147483647) || (structPtr->a != 32767)) goto Fail; intPtr = &(s.a); if (*intPtr != 32767) goto Fail; longPtr = &(s.L); if (*longPtr != 2147483647) goto Fail; colorPtr = &color; color = black; if (*colorPtr != black) goto Fail; unionPtr = &un; un.first = 12; if (unionPtr->first != 12) goto Fail; un.second = 2147483646; if (unionPtr->second != 2147483646) goto Fail; printf ("Passed Conformance Test 4.5.2.3\n"); return; Fail: printf ("Failed Conformance Test 4.5.2.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.3.1.CC b/Tests/Conformance/C4.5.3.1.CC new file mode 100755 index 0000000..10762bb --- /dev/null +++ b/Tests/Conformance/C4.5.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.3.1: Verfication of local array declarations */ #include main () { char ch; int i, j, k, n; /* loop indices */ long L; /* l-values */ unsigned int ui; unsigned long ul; float f; double d; extended e; int i1 [50], i3 [3] [5] [8]; /* all basic types */ long L1 [9], L2 [2] [6]; unsigned int ui3 [4] [5] [1], ui1 [7]; unsigned long ul2 [5] [3], ul1 [1]; comp c1 [3], c2 [2] [3]; char ch2 [6] [5], ch1 [10]; float f1 [3], f4 [2] [3] [1] [4]; double d2 [2] [4], d1 [8]; extended e1 [9], e2 [7] [3]; /* conglomerate types */ struct s { int a; float f; } s1 [10], s2 [5] [4]; enum colors { red, black, green } C3 [2] [1] [3], C1 [6]; union longOrShort { int first; long second; } u2 [3] [3], u1 [12]; for (ch = 'a', i = 0; i < 6; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* character arrays */ ch2 [i] [j] = ch++; for (ch = '~', n = 5; n >= 0; n--) for (k = 4; k >= 0; k--) if (ch2 [n] [k] != ch--) goto Fail; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ ch1 [i] = (char) (i + 0x41); /* character arrays */ for (ch = 'J', i = 9; i >= 0; i--) if (ch1 [i] != ch--) goto Fail; for (i = 0; i < 50; i++) /* assign & check singly-dimensioned */ i1 [i] = i; /* integer array */ for (i = 49; i >= 0; i--) if (i1 [i] != i) goto Fail; for (i = 0; i < 3; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* integer array */ for (k = 0; k < 8; k++) i3 [i] [j] [k] = k; for (i = 2; i >= 0; i--) for (j = 4; j >= 0; j--) for (k = 7; k >= 0; k--) if (i3 [i] [j] [k] != k) goto Fail; for (i = 8; i >= 0; i--) /* assign & check singly-dimensioned */ L1 [i] = 2147483647; /* long integer array */ for (i = 0; i < 9; i++) if (L1 [i] != 2147483647) goto Fail; for (L = 2147483646, i = 0; i < 2; i++) /* assign & check multiply- */ for (j = 0; j < 6; j++) /* dimensioned long integer*/ L2 [i] [j] = L--; /* array */ for (L = 2147483635, i = 1; i >= 0; i--) for (j = 5; j >= 0; j--) if (L2 [i] [j] != L++) goto Fail; for (ui = 65534, i = 0; i < 7; i++) /* assign & check singly-dimensioned */ ui1 [i] = ui--; /* unsigned integer array */ for (ui = 65528, i = 6; i >= 0; i--) if (ui1 [i] != ui++) goto Fail; for (ui = 65534, i = 0; i < 4; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* unsigned integer array */ for (k = 0; k < 1; k++) ui3 [i] [j] [k] = ui--; for (ui = 65515, i = 3, k = 0; i >= 0; i--) for (j = 4; j >= 0; j--) if (ui3 [i] [j] [k] != ui++) goto Fail; for (ul = 4294967279ul, i = 0; i < 5; i++) /* assign & check multiply- */ for (j = 0; j < 3; j++) /* dimensioned unsigned */ ul2 [i] [j] = ul++; /* long integer array */ for (ul = 4294967293ul, i = 4; i >= 0; i--) for (j = 2; j >= 0; j--) if (ul2 [i] [j] != ul--) goto Fail; ul1 [0] = ul; /* assign & check singly-dimensioned */ if (ul1 [0] != 4294967278ul) /* unsigned long integer array */ goto Fail; for (i = 0; i < 3; i++) /* assign & check singly-dimensioned */ c1 [i] = i; /* comp array */ for (j = 2; j >= 0; j--) if (c1 [j] != j) goto Fail; for (i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* comp array */ c2 [i] [j] = 0; for (k = 1; k >= 0; k--) for (i = 2; i >= 0; i--) if (c2 [k] [i] != 0) goto Fail; f1 [0] = f1 [1] = f1 [2] = 43.8; /* assign & check singly-dimensioned */ for (k = 0; k < 3; k++) /* float array */ if (fabs(f1 [k] - 43.8) > 0.00001) goto Fail; for (f = 1.0, i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* float array */ for (k = 0; k < 1; k++) for (n = 0; n < 4; n++) f4 [i] [j] [k] [n] = f++; for (f = 1.0, i = 0; i < 2; i++) for (j = 0; j < 3; j++) for (k = 0; k < 1; k++) for (n = 0; n < 4; n++) if (fabs(f4 [i] [j] [k] [n] - (f++)) > 0.00001) goto Fail; for (i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 4; j++) /* double array */ d2 [i] [j] = 0.00; for (d = 0, k = 1; k >= 0; k--) for (i = 3; i >= 0; i--) if (d2 [k] [i] != d) goto Fail; for (d1 [0] = 5.6, i = 1; i < 8; i++) /* assign & check singly- */ d1 [i] = d1 [i-1] + 1.0; /* dimensioned double array */ for (d = 12.6, k = 7; k >= 0; k--) if (d1 [k] != d--) goto Fail; for (e = 96e-75, i = 0; i < 7; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* extended array */ e2 [i] [j] = e; for (i = 0; i < 7; i++) for (j = 0; j < 3; j++) if (e2 [i] [j] != 96.0e-75) goto Fail; for (k = 8; k >= 0; k--) /* assign & check singly-dimensioned */ e1 [k] = 0; /* extended array */ for (e = 0.000, i = 0; i < 9; i++) if (e1 [i] != e) goto Fail; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ { /* array of structures */ s1 [i].a = i; s1 [i].f = (float) i * 2.0; } for (i = 0; i < 10; i++) { if ((s1 [i].a != i) || (fabs(s1 [i].f - i * 2.0) > 0.00001)) goto Fail; } for (n = 32766, f = 29.8E10, i = 0; i < 5; i++) /* assign & check multipy- */ for (j = 0; j < 4; j++) /* dimensioned array of */ { /* structures */ s2 [i] [j].a = n--; s2 [i] [j].f = f; } for (n = 32766, f = 29.8e10, i = 0; i < 5; i++) for (j = 0; j < 4; j++) if ((s2 [i] [j].a != n--) || (fabs(s2 [i] [j].f - f) > 0.00001)) goto Fail; for (i = 1, j = 0, k = 0; k < 3; k++) /* assign & check multiply- */ C3 [i] [j] [k] = red; /* dimensioned array of */ for (i = 0, k = 0; k < 3; k++) /* enumerations */ C3 [i] [j] [k] = green; for (k = 0; k < 3; k++) if (C3 [0] [0] [k] != green) goto Fail; for (k = 0; k < 3; k++) if (C3 [1] [0] [k] != red) goto Fail; for (n = 5; n >= 0; n--) /* assign & check singly- */ C1 [n] = black; /* dimensioned array of */ for (k = 0; k < 6; k++) /* enumerations */ if (C1 [k] != 1) goto Fail; for (i = 0; i < 3; i++) /* assign & check multiply- */ for (j = 0; j < 3; j++) /* dimensioned array of */ u2 [i] [j].first = j; /* unions */ for (n = 2; n >= 0; n--) if (u2 [n] [0].first != 0) goto Fail; for (n = 2; n >= 0; n--) if (u2 [n] [1].first != 1) goto Fail; for (n = 2; n >= 0; n--) if (u2 [n] [2].first != 2) goto Fail; for (L = 2147483646, i = 0; i < 3; i++) for (j = 0; j < 3; j++) u2 [i] [j].second = L--; for (L = 2147483646, k = 0; k < 3; k++) for (n = 0; n < 3; n++) if (u2 [k] [n].second != L--) goto Fail; for (i = 0; i < 12; i++) /* assign & check singly-dimensioned */ u1 [i].first = i; /* array of unions */ for (k = 11; k >= 0; k--) if (u1 [k].first != k) goto Fail; for (L = 32767, j = 0; j < 12; j++) u1 [j].second = L++; for (L = 32778, n = 11; n >= 0; n--) if (u1 [n].second != L--) goto Fail; printf ("Passed Conformance Test 4.5.3.1\n"); return; Fail: printf ("Failed Conformance Test 4.5.3.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.3.2.CC b/Tests/Conformance/C4.5.3.2.CC new file mode 100755 index 0000000..3b582c0 --- /dev/null +++ b/Tests/Conformance/C4.5.3.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.3.2: Verfication of static array declarations */ #include static int i1 [50], i3 [3] [5] [8]; /* all basic types */ static long L1 [9], L2 [2] [6]; static unsigned int ui3 [4] [5] [1], ui1 [7]; static unsigned long ul2 [5] [3], ul1 [1]; static comp c1 [3], c2 [2] [3]; static char ch2 [6] [5], ch1 [10]; static float f1 [3], f4 [2] [3] [1] [4]; static double d2 [2] [4], d1 [8]; static extended e1 [9], e2 [7] [3]; /* conglomerate types */ struct s { int a; float f; }; static struct s s1 [10], s2 [5] [4]; enum colors { red, black, green }; static enum colors C3 [2] [1] [3], C1 [6]; union longOrShort { int first; long second; }; static union longOrShort u2 [3] [3], u1 [12]; main () { static int TestArray (void); if ( TestArray() ) printf ("Passed Conformance Test 4.5.3.2\n"); else printf ("Failed Conformance Test 4.5.3.2\n"); } /****************************************************************************/ static int TestArray ( void ) { int i, j, k, n; /* loop indices */ long L; /* l-values */ char ch; float f; double d; extended e; unsigned int ui; unsigned long ul; for (i = 0; i < 50; i++) /* assign & check singly-dimensioned */ i1 [i] = i; /* integer array */ for (i = 49; i >= 0; i--) if (i1 [i] != i) goto Fail; for (i = 0; i < 3; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* integer array */ for (k = 0; k < 8; k++) i3 [i] [j] [k] = k; for (i = 2; i >= 0; i--) for (j = 4; j >= 0; j--) for (k = 7; k >= 0; k--) if (i3 [i] [j] [k] != k) goto Fail; for (ch = 'a', i = 0; i < 6; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* character arrays */ ch2 [i] [j] = ch++; for (ch = '~', n = 5; n >= 0; n--) for (k = 4; k >= 0; k--) if (ch2 [n] [k] != ch--) goto Fail; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ ch1 [i] = (char) (i + 0x41); /* character arrays */ for (ch = 'J', i = 9; i >= 0; i--) if (ch1 [i] != ch--) goto Fail; for (i = 8; i >= 0; i--) /* assign & check singly-dimensioned */ L1 [i] = 2147483647; /* long integer array */ for (i = 0; i < 9; i++) if (L1 [i] != 2147483647) goto Fail; for (L = 2147483646, i = 0; i < 2; i++) /* assign & check multiply- */ for (j = 0; j < 6; j++) /* dimensioned long integer*/ L2 [i] [j] = L--; /* array */ for (L = 2147483635, i = 1; i >= 0; i--) for (j = 5; j >= 0; j--) if (L2 [i] [j] != L++) goto Fail; for (ui = 65534, i = 0; i < 7; i++) /* assign & check singly-dimensioned */ ui1 [i] = ui--; /* unsigned integer array */ for (ui = 65528, i = 6; i >= 0; i--) if (ui1 [i] != ui++) goto Fail; for (ui = 65534, i = 0; i < 4; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* unsigned integer array */ for (k = 0; k < 1; k++) ui3 [i] [j] [k] = ui--; for (ui = 65515, i = 3, k = 0; i >= 0; i--) for (j = 4; j >= 0; j--) if (ui3 [i] [j] [k] != ui++) goto Fail; for (ul = 4294967279ul, i = 0; i < 5; i++) /* assign & check multiply- */ for (j = 0; j < 3; j++) /* dimensioned unsigned */ ul2 [i] [j] = ul++; /* long integer array */ for (ul = 4294967293ul, i = 4; i >= 0; i--) for (j = 2; j >= 0; j--) if (ul2 [i] [j] != ul--) goto Fail; ul1 [0] = ul; /* assign & check singly-dimensioned */ if (ul1 [0] != 4294967278ul) /* unsigned long integer array */ goto Fail; for (i = 0; i < 3; i++) /* assign & check singly-dimensioned */ c1 [i] = i; /* comp array */ for (j = 2; j >= 0; j--) if (c1 [j] != j) goto Fail; for (i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* comp array */ c2 [i] [j] = 0; for (k = 1; k >= 0; k--) for (i = 2; i >= 0; i--) if (c2 [i] [j] != 0) goto Fail; f1 [0] = f1 [1] = f1 [2] = 43.8; /* assign & check singly-dimensioned */ for (k = 0; k < 3; k++) /* float array */ if (fabs(f1 [k] - 43.8) > 0.00001) goto Fail; for (f = 1.0, i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* float array */ for (k = 0; k < 1; k++) for (n = 0; n < 4; n++) f4 [i] [j] [k] [n] = f++; for (f = 1.0, i = 0; i < 2; i++) for (j = 0; j < 3; j++) for (k = 0; k < 1; k++) for (n = 0; n < 4; n++) if (fabs(f4 [i] [j] [k] [n] - f++) > 0.00001) goto Fail; for (i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 4; j++) /* double array */ d2 [i] [j] = 0.00; for (d = 0, k = 1; k >= 0; k--) for (i = 3; i >= 0; i--) if (d2 [k] [i] != d) goto Fail; for (d1 [0] = 5.6, i = 1; i < 8; i++) /* assign & check singly- */ d1 [i] = d1 [i-1] + 1.0; /* dimensioned double array */ for (d = 12.6, k = 7; k >= 0; k--) if (d1 [k] != d--) goto Fail; for (e = 96e-75, i = 0; i < 7; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* extended array */ e2 [i] [j] = e; for (i = 0; i < 7; i++) for (j = 0; j < 3; j++) if (fabs(e2 [i] [j] - 96.0e-75) > 0.00001) goto Fail; for (k = 8; k >= 0; k--) /* assign & check singly-dimensioned */ e1 [k] = 0; /* extended array */ for (e = 0.000, i = 0; i < 9; i++) if (e1 [i] != e) goto Fail; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ { /* array of structures */ s1 [i].a = i; s1 [i].f = (float) i * 2.0; } for (i = 0; i < 10; i++) if ((s1 [i].a != i) || (fabs(s1 [i].f - i * 2.0) > 0.00001)) goto Fail; for (n = 32766, f = 29.8E10, i = 0; i < 5; i++) /* assign & check multipy- */ for (j = 0; j < 4; j++) /* dimensioned array of */ { /* structures */ s2 [i] [j].a = n--; s2 [i] [j].f = f; } for (n = 32766, f = 29.8e10, i = 0; i < 5; i++) for (j = 0; j < 4; j++) if ((s2 [i] [j].a != n--) || (fabs(s2 [i] [j].f - f) > 0.00001)) goto Fail; for (i = 1, j = 0, k = 0; k < 3; k++) /* assign & check multiply- */ C3 [i] [j] [k] = red; /* dimensioned array of */ for (i = 0, k = 0; k < 3; k++) /* enumerations */ C3 [i] [j] [k] = green; for (k = 0; k < 3; k++) if (C3 [0] [0] [k] != green) goto Fail; for (k = 0; k < 3; k++) if (C3 [1] [0] [k] != red) goto Fail; for (n = 5; n >= 0; n--) /* assign & check singly- */ C1 [n] = black; /* dimensioned array of */ for (k = 0; k < 6; k++) /* enumerations */ if (C1 [k] != 1) goto Fail; for (i = 0; i < 3; i++) /* assign & check multiply- */ for (j = 0; j < 3; j++) /* dimensioned array of */ u2 [i] [j].first = j; /* unions */ for (n = 2; n >= 0; n--) if (u2 [n] [0].first != 0) goto Fail; for (n = 2; n >= 0; n--) if (u2 [n] [1].first != 1) goto Fail; for (n = 2; n >= 0; n--) if (u2 [n] [2].first != 2) goto Fail; for (L = 2147483646, i = 0; i < 3; i++) for (j = 0; j < 3; j++) u2 [i] [j].second = L--; for (L = 2147483646, i = 0; i < 3; i++) for (j = 0; j < 3; j++) if (u2 [i] [j].second != L--) goto Fail; for (i = 0; i < 12; i++) /* assign & check singly-dimensioned */ u1 [i].first = i; /* array of unions */ for (k = 11; k >= 0; k--) if (u1 [k].first != k) goto Fail; for (L = 32767, j = 0; j < 12; j++) u1 [j].second = L++; for (L = 32767, j = 0; j < 12; j++) if (u1[j].second != L++) goto Fail; return (1); Fail: return (0); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.3.3.CC b/Tests/Conformance/C4.5.3.3.CC new file mode 100755 index 0000000..4e8a416 --- /dev/null +++ b/Tests/Conformance/C4.5.3.3.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.3.3: Verfication of local array declarations: arrays */ /* of pointers */ #include main () { int i, j, k, n; /* loop indices */ long L; /* l-values */ float f; double d; extended e; comp cmp; unsigned int ui; unsigned long ul; char ch; int *i1 [50]; /* all basic types */ long *L1 [9]; comp *c1 [3]; char *ch1 [10]; float *f1 [3]; double *d1 [8]; extended *e1 [9]; unsigned int ui3 [4] [5] [1], *ui1 [7]; unsigned long ul2 [5] [3], *ul1 [1]; /* conglomerate types */ struct s { int a; float f; } *s1 [10], S; enum colors { red, black, green } *en [6], C; union longOrShort { int first; long second; } *u1 [12], U; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ ch1 [i] = &ch; /* array of pointers to character */ ch = 'z'; for (i = 9; i >= 0; i--) if (*(ch1 [i]) != 'z') goto Fail; for (i = 0; i < 50; i++) /* assign & check singly-dimensioned */ i1 [i] = &n; /* array of pointers to int */ n = 32767; for (i = 49; i >= 0; i--) if (*(i1 [i]) != 32767) goto Fail; for (i = 8; i >= 0; i--) /* assign & check singly-dimensioned */ L1 [i] = &L; /* array of pointers to long int */ L = 2147483647; for (i = 0; i < 9; i++) if (*(L1 [i]) != 2147483647) goto Fail; for (i = 0; i < 7; i++) /* assign & check singly-dimensioned */ ui1 [i] = &ui; /* array of ptrs to unsigned int */ ui = 65535; for (i = 6; i >= 0; i--) if (*(ui1 [i]) != 65535) goto Fail; ul1 [0] = &ul; /* assign & check singly-dimensioned */ ul = 4294967295ul; /* array of ptrs to long unsigned int*/ if (*(ul1 [0]) != 0xffffffff) goto Fail; for (i = 0; i < 3; i++) /* assign & check singly-dimensioned */ c1 [i] = &cmp; /* array of pointers to comp */ cmp = 4; for (j = 2; j >= 0; j--) if (*(c1 [j]) != 4) goto Fail; f1 [0] = f1 [1] = f1 [2] = &f; /* assign & check singly-dimensioned */ f = 32.8; /* array of pointers to float */ for (k = 0; k < 3; k++) if (fabs(*(f1 [k]) - 32.8) > 0.00001) goto Fail; for (i = 0; i < 8; i++) /* assign & check singly- */ d1 [i] = &d; /* dimensioned array of */ d = 123.0e50; /* pointers to double */ for (k = 7; k >= 0; k--) if (fabs(*(d1 [k]) - 0.123E53) > 0.00001) goto Fail; for (k = 8; k >= 0; k--) /* assign & check singly-dimensioned */ e1 [k] = &e; /* array of pointers to extended */ e = 0.0e-300; for (i = 0; i < 9; i++) if (*(e1 [i]) != 0) goto Fail; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ s1 [i] = &S; /* array of pointers to structures */ S.a = 7; S.f = 6.4; for (i = 9; i >= 0; i--) if ((s1 [i]->a != 7) || (fabs(s1 [i]->f - 6.4) > 0.00001)) goto Fail; for (n = 5; n >= 0; n--) /* assign & check singly-dimensioned */ en [n] = &C; /* array of pointers to enumerations*/ C = black; for (k = 0; k < 6; k++) if (*(en [k]) != 1) goto Fail; for (i = 0; i < 12; i++) /* assign & check singly-dimensioned */ u1 [i] = &U; /* array of pointers to union */ U.first = -45; for (k = 11; k >= 0; k--) if (u1 [k]->first != -45) goto Fail; U.second = 32770; for (n = 11; n >= 0; n--) if (u1 [n]->second != 32770) goto Fail; printf ("Passed Conformance Test 4.5.3.3\n"); return; Fail: printf ("Failed Conformance Test 4.5.3.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.3.4.CC b/Tests/Conformance/C4.5.3.4.CC new file mode 100755 index 0000000..363cc12 --- /dev/null +++ b/Tests/Conformance/C4.5.3.4.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.3.4: Verfication of static array declarations: arrays */ /* of pointers */ #include static int *i1 [50]; /* all basic types */ static long *L1 [9]; static comp *c1 [3]; static char *ch1 [10]; static float *f1 [3]; static double *d1 [8]; static extended *e1 [9]; static unsigned int ui3 [4] [5] [1], *ui1 [7]; static unsigned long ul2 [5] [3], *ul1 [1]; /* conglomerate types */ struct s { int a; float f; }; static struct s *s1 [10], S; enum colors { red, black, green }; static enum colors *en [6], C; union longOrShort { int first; long second; }; static union longOrShort *u1 [12], U; main () { static int TestEm (void); if (TestEm()) printf ("Passed Conformance Test 4.5.3.4\n"); else printf ("Failed Conformance Test 4.5.3.4\n"); } /****************************************************************************/ static int TestEm (void) { char ch; comp cmp; int i, j, k, n; /* loop indices */ long L; /* l-values */ float f; double d; extended e; unsigned int ui; unsigned long ul; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ ch1 [i] = &ch; /* array of pointers to character */ ch = 'z'; for (i = 9; i >= 0; i--) if (*(ch1 [i]) != 'z') goto Fail; for (i = 0; i < 50; i++) /* assign & check singly-dimensioned */ i1 [i] = &n; /* array of pointers to int */ n = 32767; for (i = 49; i >= 0; i--) if (*(i1 [i]) != 32767) goto Fail; for (i = 8; i >= 0; i--) /* assign & check singly-dimensioned */ L1 [i] = &L; /* array of pointers to long int */ L = 2147483647; for (i = 0; i < 9; i++) if (*(L1 [i]) != 2147483647) goto Fail; for (i = 0; i < 7; i++) /* assign & check singly-dimensioned */ ui1 [i] = &ui; /* array of ptrs to unsigned int */ ui = 65535; for (i = 6; i >= 0; i--) if (*(ui1 [i]) != 65535) goto Fail; ul1 [0] = &ul; /* assign & check singly-dimensioned */ ul = 4294967295ul; /* array of ptrs to long unsigned int*/ if (*(ul1 [0]) != 0xffffffff) goto Fail; for (i = 0; i < 3; i++) /* assign & check singly-dimensioned */ c1 [i] = &cmp; /* array of pointers to comp */ cmp = 4; for (j = 2; j >= 0; j--) if (*(c1 [j]) != 4) goto Fail; f1 [0] = f1 [1] = f1 [2] = &f; /* assign & check singly-dimensioned */ f = 32.8; /* array of pointers to float */ for (k = 0; k < 3; k++) if (fabs(*(f1 [k]) - 32.8) > 0.00001) goto Fail; for (i = 0; i < 8; i++) /* assign & check singly- */ d1 [i] = &d; /* dimensioned array of */ d = 123.0e50; /* pointers to double */ for (k = 7; k >= 0; k--) if (fabs(*(d1 [k]) - 0.123E53) > 0.00001) goto Fail; for (k = 8; k >= 0; k--) /* assign & check singly-dimensioned */ e1 [k] = &e; /* array of pointers to extended */ e = 0.0e-300; for (i = 0; i < 9; i++) if (*(e1 [i]) != 0) goto Fail; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ s1 [i] = &S; /* array of pointers to structures */ S.a = 7; S.f = 6.4; for (i = 9; i >= 0; i--) if ((s1 [i]->a != 7) || (fabs(s1 [i]->f - 6.4) > 0.00001)) goto Fail; for (n = 5; n >= 0; n--) /* assign & check singly-dimensioned */ en [n] = &C; /* array of pointers to enumerations*/ C = black; for (k = 0; k < 6; k++) if (*(en [k]) != 1) goto Fail; for (i = 0; i < 12; i++) /* assign & check singly-dimensioned */ u1 [i] = &U; /* array of pointers to union */ U.first = -45; for (k = 11; k >= 0; k--) if (u1 [k]->first != -45) goto Fail; U.second = 32770; for (n = 11; n >= 0; n--) if (u1 [n]->second != 32770) goto Fail; return 1; Fail: return 0; } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.4.1.CC b/Tests/Conformance/C4.5.4.1.CC new file mode 100755 index 0000000..e3fd6ea --- /dev/null +++ b/Tests/Conformance/C4.5.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.4.1: Verification of function declarators */ #include #include /***************************************************************************/ static int I1 (int (*func1) (char a), int (*func2) (float f)) { return ( ((*func1) ('a')) + (func2 (3.5)) ); } /***************************************************************************/ static int I2 (int (*func []) (char a)) { int j; j = (*func) ('@'); j += (func[1]) ('@'); return j; } /***************************************************************************/ main () { int i; int Char1 (char ch); /* define two different functions which */ int Char2 (char ch); /* take 1 char parm and return int */ int Float1 (float f); /* define two different functions which */ int Float2 (float f); /* take 1 float parm and return int */ int (*f1Ptr) (char); /* pointer to function returning int */ /* function has single char arg */ int (*f1Array [3]) (char); /* array of pointers to functions */ /* returning int & having single */ /* char parameter */ int (*f2Ptr) (float); /* pointer to function returning int */ /* function has single float arg */ f1Ptr = Char1; f2Ptr = Float2; i = I1 (f1Ptr, f2Ptr); if (i != 0xC3) goto Fail; f1Ptr = Char2; f2Ptr = Float1; i = I1 (f1Ptr, f2Ptr); if (i != 0xD4) goto Fail; i = I1 (Char1, Float1); if (i != 0xD3) goto Fail; f1Array [0] = Char1; f1Array [1] = Char2; f1Array [2] = NULL; i = I2 (f1Array); if (i != 0x143) goto Fail; printf ("Passed Conformance Test 4.5.4.1\n"); return; Fail: printf ("Failed Conformance Test 4.5.4.1\n"); } /***************************************************************************/ int Char1 (char ch) { return (ch + 'a'); } /***************************************************************************/ int Char2 (char ch) { return ((ch) + ('b')); } /***************************************************************************/ int Float1 (float f) { return (int) ((f) * 5.0); } /***************************************************************************/ int Float2 (float f) { return (int) (f / 2.0); } \ No newline at end of file diff --git a/Tests/Conformance/C4.5.4.2.CC b/Tests/Conformance/C4.5.4.2.CC new file mode 100755 index 0000000..989a2aa --- /dev/null +++ b/Tests/Conformance/C4.5.4.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.5.4.2: Verification of function declarators, using */ /* non-prototyped form */ #include #include /***************************************************************************/ static int I1 (func1, func2) int (*func1) (); int (*func2) (); { return ( ((*func1) ('a')) + ((*func2) (3.5)) ); } /***************************************************************************/ static int I2 (func) int (*func []) (); { int j; j = (*func) ('@'); j += (func[1]) ('@'); return j; } /***************************************************************************/ main () { int i; int Char1 (), Char2 (); /* define external functions */ int Float1 (), Float2(); int (*f1Ptr) (); /* pointer to function returning int */ int (*f2Ptr) (); int (*f1Array [3]) (); /* array of pointers to functions */ /* returning int */ f1Ptr = Char1; f2Ptr = Float2; i = I1 (f1Ptr, f2Ptr); if (i != 0xC3) goto Fail; f1Ptr = Char2; f2Ptr = Float1; i = I1 (f1Ptr, f2Ptr); if (i != 0xD4) goto Fail; i = I1 (Char1, Float1); if (i != 0xD3) goto Fail; f1Array [0] = Char1; f1Array [1] = Char2; f1Array [2] = NULL; i = I2 (f1Array); if (i != 0x143) goto Fail; printf ("Passed Conformance Test 4.5.4.2\n"); return; Fail: printf ("Failed Conformance Test 4.5.4.2\n"); } /***************************************************************************/ int Char1 (ch) char ch; { return (ch + 'a'); } /***************************************************************************/ int Char2 (ch) char ch; { return ((ch) + ('b')); } /***************************************************************************/ int Float1 (f) float f; { return (int) ((f) * 5.0); } /***************************************************************************/ int Float2 (f) float f; { return (int) (f / 2.0); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.1.1.CC b/Tests/Conformance/C4.6.1.1.CC new file mode 100755 index 0000000..7cb2c74 --- /dev/null +++ b/Tests/Conformance/C4.6.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.1.1: Initialization of integer variables */ #define ONE 1 #define TWO 2 /* static and extern variables can only be initialized with constant exprs */ static int i = 8 << 2 + 6 - 7 / 3 >> 1 * 5 % (sizeof (int)); long j = ONE <= 5; /* default storage class at top-level is extern */ char ch = ~'a' - 0x20; int gk = 0x7D; unsigned gu1 = 0x7D; main () { /* auto & register integers can be initialized with arbitrary expressions */ /* default storage class at head of block is auto */ int k = ch - j; unsigned u1 = gk | i & j; long m = (long) (gu1 ^ gk); unsigned long n = 4294967295ul >> gk; char chr = 'z' * (gk / 'b'); register int k1 = ch - j; register unsigned un1 = gk| i & j; register long m1 = (long) (gu1 ^ gk); register unsigned long n1 = 4294967295ul >> 8; register char chr1 = 'z' * (gk / 'b') + TWO; if ((i != 0x100) || (j != 1) || (ch != 0x7E) || (k != 0x7D) || (n1 != 0x00FFFFFF)) goto Fail; if ((m != 0) || (n != 0) || (chr != 0x7A) || (k1 != 0x7D) || (un1 != 0x7D)) goto Fail; if ((m1 != 0) || (chr1 != 0x7C)) goto Fail; printf ("Passed Conformance Test 4.6.1.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.1.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.1.2.CC b/Tests/Conformance/C4.6.1.2.CC new file mode 100755 index 0000000..0e79eb9 --- /dev/null +++ b/Tests/Conformance/C4.6.1.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.1.2: Initialization of integer variables, using */ /* curly-braced expressions. Verification of */ /* zeroing of non-initialized static variables */ /* is also checked. */ #define ONE 1 #define TWO 2 /* static and extern variables can only be initialized with constant exprs */ static int i; long j = { ONE <= 5 }; /* default storage class at top-level is extern */ char ch = {~'a' - 0x20}; main () { /* auto & register integers can be initialized with arbitrary expressions */ /* default storage class at head of block is auto */ static char chr8; static long longStatic; int k = { ch - j }; { unsigned u1 = {k | i & j}; { long m = {(long) (u1 ^ k)}; unsigned long n = { 4294967295ul >> k }; char chr = { 'z' * (k / 'b') }; register int k1 = {ch - j}; register unsigned un1 = {k | i & j}; { register long m1 = { (long) (u1 ^ k) }; register unsigned long n1 = { 4294967295ul >> 8 }; register char chr1 = { 'z' * (k / 'b') + TWO }; if ((i != 0) || (j != 1) || (ch != 0x7E) || (k != 0x7D) || (n1 != 0x00FFFFFF)) goto Fail; if ((m != 0) || (n != 0) || (chr != 0x7A) || (k1 != 0x7D) || (un1 != 0x7D)) goto Fail; if ((m1 != 0) || (n1 != 0x00FFFFFF) || (chr1 != 0x7C) || (chr8 != 0) || \ (longStatic != 0)) goto Fail; printf ("Passed Conformance Test 4.6.1.2\n"); return; Fail: printf ("Failed Conformance Test 4.6.1.2\n"); }}} } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.2.1.CC b/Tests/Conformance/C4.6.2.1.CC new file mode 100755 index 0000000..02bb2fe --- /dev/null +++ b/Tests/Conformance/C4.6.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.2.1: Verification of floating-point initializers */ /* static and extern variables are restricted to constant expressions */ #include static float f1 = -1.0E2 + (float) 2 * 5.0 / 20.0 - (double) 6; static double d1 = 89.76E5 * 17.6 - (extended) 1 + (float) (-3) / 8.; static extended e1 = 9.9 * 7.1 + 0.03 - (extended) 2 / (float) (0 && 3.0 || 2); float f2 = 5.1 * 7 - 88 / 4 + (extended) (double) (float) 8; double d2 = 10.0e20 / 0.04E-6; extended e2 = 15.5 - .5 * 3 + 1; main () { /* auto and register variables can use any arithmetic expression */ float f3 = f1 * f2 / 1; double d3 = 8.1; { extended e3 = e1 && e2 || d3 - f3; { register float f4 = f3; register double d4 = f3 / 2.0; { register extended e4 = d4 + (extended) 8.88 - f1 / 5.0; if (fabs(f1 - (-105.5)) > 0.00001) goto Fail; if (fabs(f2 - 21.7) > 0.00001) goto Fail; if (fabs(f3 - (-2289.35)) > 0.001) goto Fail; if (fabs(f4 - (-2289.35)) > 0.001) goto Fail; if (fabs(d1 - 157977600.0) > 100.0) goto Fail; if (fabs(d2 - 2.5e28) > 1e21) goto Fail; if (fabs(d3 - 8.1) > 0.00001) goto Fail; if (fabs(d4 - (-1144.675)) > 0.01) goto Fail; if (fabs(e1 - 68.32) > 0.0001) goto Fail; if (fabs(e2 - 15.0) > 0.0001) goto Fail; if (fabs(e3 - 1.0) > 0.00001) goto Fail; if (fabs(e4 - (-1114.695)) > 0.001) goto Fail; printf ("Passed Conformance Test 4.6.2.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.2.1\n"); }}} } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.2.2.CC b/Tests/Conformance/C4.6.2.2.CC new file mode 100755 index 0000000..2527a1c --- /dev/null +++ b/Tests/Conformance/C4.6.2.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.2.1: Verification of floating-point initializers */ /* Ensure non-initialized static variables are */ /* zeroed, and that curly braces can enclose */ /* initialization expression. */ /* static and extern variables are restricted to constant expressions */ #include static float f1 = { -1.0E2 + (float) 2 * 5.0 / 20.0 - (double) 6 }; static double d1 = { 89.76E5 * 17.6 - (extended) 1 + (float) (-3) / 8.0 }; static extended e1; static float f0; float f2 = 5.1 * 7 - 88 / 4 + (extended) (double) (float) 8; double d2 = { 10.0e20 / 0.04E-6 }; extended e2 = 15.5 - .5 * 3 + 1; main () { static double d0; /* auto and register variables can use any arithmetic expression */ float f3 = {f1 * f2 / 1}; double d3 = 8.1; { extended e3 = {e1 && e2 || d3 - f3}; register float f4 = {f3}; register double d4 = {f3 / 2.0}; { register extended e4 = d4 + (extended) 8.88 - f1 / 5.0; if (fabs(f1 - (-105.5)) > 0.0001) goto Fail; if (fabs(f2 - 21.7) > 0.0001) goto Fail; if (fabs(f3 - (-2289.35)) > 0.01) goto Fail; if (fabs(f4 - (-2289.35)) > 0.01) goto Fail; if (fabs(d1 - 157977598.625) > 1.0000) goto Fail; if (fabs(d2 - 2.5e28) > 1e23) goto Fail; if (fabs(d3 - 8.1) > 0.00001) goto Fail; if (fabs(d4 - (-1144.675)) > 0.01) goto Fail; if (fabs(e1) > 0.00001) goto Fail; if (fabs(e2 - 15.0) > 0.0001) goto Fail; if (fabs(e3 - 1.0) > 0.00001) goto Fail; if (fabs(e4 - (-1114.695)) > 0.001) goto Fail; if (fabs(f0) > 0.00001) goto Fail; if (fabs(d0) > 0.00001) goto Fail; printf ("Passed Conformance Test 4.6.2.2\n"); return; Fail: printf ("Failed Conformance Test 4.6.2.2\n"); }}} \ No newline at end of file diff --git a/Tests/Conformance/C4.6.3.1.CC b/Tests/Conformance/C4.6.3.1.CC new file mode 100755 index 0000000..78f0283 --- /dev/null +++ b/Tests/Conformance/C4.6.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.3.1: Verification of pointer initializers */ /* static and extern pointer variables can use only constant expressions */ #include struct S { int a; float b; }; union U { int i; long L; }; enum E { a, b, c }; static int *i1Ptr = NULL; /* constant expression can contain NULL */ static char *ch1Ptr = NULL; static long *L1Ptr = NULL; static comp *c1Ptr = NULL; static float *f1Ptr = NULL; static double *d1Ptr = NULL; static extended *e1Ptr = NULL; static unsigned int *ui1Ptr = NULL; static unsigned long *uL1Ptr = NULL; static struct S *struct1Ptr = NULL; static union U *union1Ptr = NULL; static enum E *enum1Ptr = NULL; int *i2Ptr = NULL; char *ch2Ptr = NULL; long *L2Ptr = NULL; comp *c2Ptr = NULL; float *f2Ptr = NULL; double *d2Ptr = NULL; extended *e2Ptr = NULL; unsigned int *ui2Ptr = NULL; unsigned long *uL2Ptr = NULL; struct S *struct2Ptr = NULL; union U *union2Ptr = NULL; enum E *enum2Ptr = NULL; main () { /* local pointer variables can also be set to NULL */ int *i3Ptr = NULL; char *ch3Ptr = NULL; long *L3Ptr = NULL; comp *c3Ptr = NULL; float *f3Ptr = NULL; double *d3Ptr = NULL; extended *e3Ptr = NULL; unsigned int *ui3Ptr = NULL; unsigned long *uL3Ptr = NULL; struct S *struct3Ptr = NULL; union U *union3Ptr = NULL; enum E *enum3Ptr = NULL; if ((i1Ptr != 0) || (i2Ptr != 0) || (i3Ptr != 0)) goto Fail; if ((ch1Ptr != 0) || (ch2Ptr != 0) || (ch3Ptr != 0)) goto Fail; if ((L1Ptr != 0) || (L2Ptr != 0) || (L3Ptr != 0)) goto Fail; if ((c1Ptr != 0) || (c2Ptr != 0) || (c3Ptr != 0)) goto Fail; if ((f1Ptr != 0) || (f2Ptr != 0) || (f3Ptr != 0)) goto Fail; if ((d1Ptr != 0) || (d2Ptr != 0) || (d3Ptr != 0)) goto Fail; if ((e1Ptr != 0) || (e2Ptr != 0) || (e3Ptr != 0)) goto Fail; if ((ui1Ptr != 0) || (ui2Ptr != 0) || (ui3Ptr != 0)) goto Fail; if ((uL1Ptr != 0) || (uL2Ptr != 0) || (uL3Ptr != 0)) goto Fail; if ((struct1Ptr != 0) || (struct2Ptr != 0) || (struct3Ptr != 0)) goto Fail; if ((union1Ptr != 0) || (union2Ptr != 0) || (union3Ptr != 0)) goto Fail; printf ("Passed Conformance Test 4.6.3.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.3.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.3.2.CC b/Tests/Conformance/C4.6.3.2.CC new file mode 100755 index 0000000..ed6c72f --- /dev/null +++ b/Tests/Conformance/C4.6.3.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.3.2: Verification of local pointer initializers */ #include struct S { int a; float b; }; union U { int i; long L; }; enum E { a, b, c }; /******************************************************************************/ int I1 (void) { return 32760; } /******************************************************************************/ long Long1 (void) { return 2147483647; } /******************************************************************************/ char Ch1 (void) { return 'm'; } /******************************************************************************/ extended E1 (void) { return 189.0E50; } /******************************************************************************/ main () { static int IDisp (int (*func) (void)); /* declare dispatcher rtns */ static char ChDisp (char (*func) (void)); static long LDisp (long (*func) (void)); static extended EDisp (extended (*func) (void)); int i1 = 8 * 10; /* define local variables */ char ch1 = 'P'; long L1 = { 0x12345678 - 0x78 }; comp c1 = { 0x12345678 }; float f1 = 98.6e-00; double d1 = 15.7e10; extended e1 = 9.8E45; unsigned int ui1 = 65535; unsigned long ul1 = { 42959796 }; struct S struct1 = { 3, 3.3 }; union U union1 = 5; enum E enum1 = c; int i2 [2] = { 160, 140 }; /* define local arrays */ char ch2 [2] = { 'e', 'O' }; long L2 [2] = { 40, 0x12345600 }; comp c2 [2] = { 0x12345678, 0x12345678 }; float f2 [2] = { 1.0, 1.0 }; double d2 [2] = { 15.7e10, 1.0 }; extended e2 [2] = { 9.8E45, 8.9E-45 }; unsigned int ui2 [2] = { 0x3FFF }; unsigned long ul2 [2] = { 0x51f0768 }; int (*i3Ptr) (void) = I1; /* pointers to functions */ char (*ch3Ptr) (void) = Ch1; long (*L3Ptr) (void) = Long1; extended (*e3Ptr) (void) = E1; int *i4Ptr = i2; /* array names */ char *ch4Ptr = ch2 + 1; long *L4Ptr = L2 + 1; comp *c4Ptr = c2 + 2 - 1; float *f4Ptr = f2; double *d4Ptr = d2 - 0; extended *e4Ptr = e2 + 1; unsigned int *ui4Ptr = ui2; unsigned long *uL4Ptr = ul2 + 1; struct S *struct5Ptr = &struct1; /* addresses of local variables */ union U *union5Ptr = &union1; enum E *enum5Ptr = &enum1; int *i5 = &i1; char *ch5 = &ch1; long *L5 = &L1; comp *c5 = &c1; float *f5 = &f1; double *d5 = &d1; extended *e5 = &e1; unsigned int *ui5 = &ui1; unsigned long *ul5 = &ul1; /* First ensure correctness of pointers to scalars */ if ((*i5 != 80) || (*ch5 != 'P') || (*L5 != 0x12345600) || (*c5 != 0x12345678) || (fabs(*f5 - 98.6) > 0.00001) || (fabs(*d5 - 15.7e10) > 0.00001) || (fabs(*e5 - 9.8e45) > 0.00001) || (*ui5 != 65535) || (*ul5 != 42959796)) goto Fail; /* Verify pointers to local arrays */ if (*i4Ptr != 160) goto Fail; if (*ch4Ptr != 'O') goto Fail; if (*L4Ptr != 0x12345600) goto Fail; if (*c4Ptr != 0x12345678) goto Fail; if (fabs(*f4Ptr - 1.0) > 0.00001) goto Fail; if (fabs(*d4Ptr - 15.7E10) > 0.00001) goto Fail; if (fabs(*e4Ptr - 8.9E-45) > 1e-50) goto Fail; if (*ui4Ptr != 0x3FFF) goto Fail; if (*uL4Ptr != 0) goto Fail; if (struct5Ptr->a != 3) goto Fail; if (fabs(struct5Ptr->b - 3.3) > 0.00001) goto Fail; if (union5Ptr->i != 5) goto Fail; if (*enum5Ptr != c) goto Fail; /* Verify pointers to functions */ i1 = IDisp (i3Ptr); if (i1 != 32760) goto Fail; ch1 = ChDisp (ch3Ptr); if (ch1 != 'm') goto Fail; L1 = LDisp (L3Ptr); if (L1 != 2147483647) goto Fail; e1 = EDisp (e3Ptr); if (fabs(e1 - 189.0E50) > 0.00001) goto Fail; printf ("Passed Conformance Test 4.6.3.2\n"); return; Fail: printf ("Failed Conformance Test 4.6.3.2\n"); } /******************************************************************************/ static int IDisp (int (*func) (void)) { return func (); } /******************************************************************************/ static char ChDisp (char (*func) (void)) { return func (); } /******************************************************************************/ static long LDisp (long (*func) (void)) { return func (); } /******************************************************************************/ static extended EDisp (extended (*func) (void)) { return func (); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.4.1.CC b/Tests/Conformance/C4.6.4.1.CC new file mode 100755 index 0000000..d1fe5ce --- /dev/null +++ b/Tests/Conformance/C4.6.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.4.1: Test initialization of static and extern arrays */ #include #include /* Check size supplied by compiler */ static int i1 [] = { 1, 2, 3 }; static int i2 [] [2] = { {4, 5}, {6, 7}, {8, 9} }; static extended e1 [] = { 1.0, 2.0, 3.0, 4.0 }; static extended e2 [] [3] = { {1.1, 1.2, 1.3}, {2.2, 2.3, 2.4} }; char ch1 [] = "Now is the time"; char ch2 [] [20] = { "for all good people", "to come to the aid " }; double d1 [] = { 5.4, 5.5, 5.6, 5.7 }; double d2 [] [2] [3] = { { {6.6, 6.7, 6.8}, {7.7, 7.8, 7.9} }, { {8.8, 8.9, 9.0}, {3.3, 3.4, 3.5} }, { {4.4, 4.5, 4.6}, {5.5, 5.6, 5.7} } }; /* Ensure that missing values are zeroed */ static long L1 [4] = { 2, 3 }; extended e3 [5] = { 1.1, 2.2, 3.3 }; static struct S1 { int x, y, z; float a, b, c; } s1 [3] = { { 1, 2, 3, 2.0, 3.0, 4.0 } }; struct S2 { char ch1, ch2; double d1, d2; } s2 [4] = { {'a', 'b', 3.3, 4.4}, {'l', 'm', 3.5, 4.6} }; main () { int i, j, k, m; /* local variables */ double d3; extended e4; /* Check sizes of arrays */ if ((sizeof (i1) != 6) || (sizeof (i2) != 12) || (sizeof (e1) != 40) || (sizeof (e2) != 60) || (sizeof (ch1) != 16) || (sizeof (ch2) != 40)) goto Fail; if ((sizeof (d1) != 32) || (sizeof (d2) != 144) || (sizeof (L1) != 16) || (sizeof (e3) != 50) || (sizeof (s1) != 54) || (sizeof (s2) != 72)) goto Fail; /* Check array contents */ for (i = 0; i < 3; i++) /* i1 */ if (i1 [i] != i + 1) goto Fail; for (i = 0, k = 4; i < 3; i++) /* i2 */ for (j = 0; j < 2; j++) { if (i2 [i] [j] != k) goto Fail; k += 1; } for (i = 0, e4 = 1.0; i < 4; i++) /* e1 */ { if (e1 [i] != e4) goto Fail; e4 += 1.0; } for (e4 = 1.1, i = 0; i < 3; i++) /* e2 */ { if (fabs(e2 [0] [i] - e4) > 0.00001) goto Fail; e4 += 0.1; } for (e4 = 2.2, i = 0; i < 3; i++) { if (fabs(e2 [1] [i] - e4) > 0.00001) goto Fail; e4 += 0.1; } if (strcmp (ch1, "Now is the time")) /* ch1 */ goto Fail; if ((strcmp (&ch2 [1], "to come to the aid ")) || /* ch2 */ (strcmp (&ch2 [0], "for all good people"))) goto Fail; for (d3 = 5.4, i = 0; i < 4; i++) /* d1 */ { if (fabs(d1 [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 6.6, i = 0; i < 3; i++) /* 0,0,0-2 of d2 */ /* d2 */ { if (fabs(d2 [0] [0] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 7.7, i = 0; i < 3; i++) /* 0,1,0-2 of d2 */ { if (fabs(d2 [0] [1] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 8.8, i = 0; i < 3; i++) /* 1,0,0-2 of d2 */ { if (fabs(d2 [1] [0] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 3.3, i = 0; i < 3; i++) /* 1,1,0-2 of d2 */ { if (fabs(d2 [1] [1] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 4.4, i = 0; i < 3; i++) /* 2,0,0-2 of d2 */ { if (fabs(d2 [2] [0] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 5.5, i = 0; i < 3; i++) /* 2,1,0-2 of d2 */ { if (fabs(d2 [2] [1] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } /* L1 */ if ((L1 [0] != 2) || (L1 [1] != 3) || (L1 [2] != 0) || (L1 [3] != 0)) goto Fail; /* e3 */ if ((fabs(e3 [0] - 1.1) > 0.00001) || (fabs(e3 [1] - 2.2) > 0.00001) || (fabs(e3 [2] - 3.3) > 0.00001) || (fabs(e3 [3]) > 0.00001) || (fabs(e3 [4] ) > 0.00001)) goto Fail; /* s1 */ if ((s1 [0].x != 1) || (s1 [0].y != 2) || (s1 [0].z != 3) || (fabs(s1 [0].a - 2.0) > 0.00001) || (fabs(s1 [0].b - 3.0) > 0.00001) || (fabs(s1 [0].c - 4.0) > 0.00001)) goto Fail; for (i = 1; i < 3; i++) if ((s1 [i].x != 0) || (s1 [i].y != 0) || (s1 [i].z != 0) || (s1 [i].a != 0.0) || (s1 [i].b != 0.0) || (s1 [i].c != 0.0)) goto Fail; /* s2 */ if ((s2 [0].ch1 != 'a') || (s2 [0].ch2 != 'b') || (s2 [1].ch1 != 'l') || (s2 [1].ch2 != 'm')) goto Fail; if ((fabs(s2 [0].d1 - 3.3) > 0.00001) || (fabs(s2 [0].d2 - 4.4) > 0.00001) || (fabs(s2 [1].d1 - 3.5) > 0.00001) || (fabs(s2 [1].d2 - 4.6) > 0.00001)) goto Fail; for (i = 2; i < 4; i++) if ((s2 [i].ch1 != 0) || (s2 [i].ch2 != 0) || (s2 [i].d1 != 0.0) || (s2 [i].d2 != 0.0)) goto Fail; printf ("Passed Conformance Test 4.6.4.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.4.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.4.2.CC b/Tests/Conformance/C4.6.4.2.CC new file mode 100755 index 0000000..705793f --- /dev/null +++ b/Tests/Conformance/C4.6.4.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.4.2: Test initialization of auto arrays */ #include #include main () { int i, j, k, m; /* local variables */ double d3; extended e4; int i1 [] = { 1, 2, 3 }; int i2 [] [2] = { {4, 5}, {6, 7}, {8, 9} }; extended e1 [] = { 1.0, 2.0, 3.0, 4.0 }; extended e2 [] [3] = { {1.1, 1.2, 1.3}, {2.2, 2.3, 2.4} }; char ch1 [] = "Now is the time"; char ch2 [] [20] = { "for all good people", "to come to the aid " }; double d1 [] = { 5.4, 5.5, 5.6, 5.7 }; double d2 [] [2] [3] = { { {6.6, 6.7, 6.8}, {7.7, 7.8, 7.9} }, { {8.8, 8.9, 9.0}, {3.3, 3.4, 3.5} }, { {4.4, 4.5, 4.6}, {5.5, 5.6, 5.7} } }; /* Ensure that missing values are zeroed */ long L1 [4] = { 2, 3 }; extended e3 [5] = { 1.1, 2.2, 3.3 }; struct S1 { int x, y, z; float a, b, c; } s1 [3] = { { 1, 2, 3, 2.0, 3.0, 4.0 } }; struct S2 { char ch1, ch2; double d1, d2; } s2 [4] = { {'a', 'b', 3.3, 4.4}, {'l', 'm', 3.5, 4.6} }; /* Check sizes of arrays */ if ((sizeof (i1) != 6) || (sizeof (i2) != 12) || (sizeof (e1) != 40) || (sizeof (e2) != 60) || (sizeof (ch1) != 16) || (sizeof (ch2) != 40)) goto Fail; if ((sizeof (d1) != 32) || (sizeof (d2) != 144) || (sizeof (L1) != 16) || (sizeof (e3) != 50) || (sizeof (s1) != 54) || (sizeof (s2) != 72)) goto Fail; /* Check array contents */ for (i = 0; i < 3; i++) /* i1 */ if (i1 [i] != i + 1) goto Fail; for (i = 0, k = 4; i < 3; i++) /* i2 */ for (j = 0; j < 2; j++) { if (i2 [i] [j] != k) goto Fail; k += 1; } for (i = 0, e4 = 1.0; i < 4; i++) /* e1 */ { if (fabs(e1 [i] - e4) > 0.00001) goto Fail; e4 += 1.0; } for (e4 = 1.1, i = 0; i < 3; i++) /* e2 */ { if (fabs(e2 [0] [i] - e4) > 0.00001) goto Fail; e4 += 0.1; } for (e4 = 2.2, i = 0; i < 3; i++) { if (fabs(e2 [1] [i] - e4) > 0.00001) goto Fail; e4 += 0.1; } if (strcmp (ch1, "Now is the time")) /* ch1 */ goto Fail; if ((strcmp (ch2 [1], "to come to the aid ")) || /* ch2 */ (strcmp (ch2 [0], "for all good people"))) goto Fail; for (d3 = 5.4, i = 0; i < 4; i++) /* d1 */ { if (fabs(d1 [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 6.6, i = 0; i < 3; i++) /* 0,0,0-2 of d2 */ /* d2 */ { if (fabs(d2 [0] [0] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 7.7, i = 0; i < 3; i++) /* 0,1,0-2 of d2 */ { if (fabs(d2 [0] [1] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 8.8, i = 0; i < 3; i++) /* 1,0,0-2 of d2 */ { if (fabs(d2 [1] [0] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 3.3, i = 0; i < 3; i++) /* 1,1,0-2 of d2 */ { if (fabs(d2 [1] [1] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 4.4, i = 0; i < 3; i++) /* 2,0,0-2 of d2 */ { if (fabs(d2 [2] [0] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } for (d3 = 5.5, i = 0; i < 3; i++) /* 2,1,0-2 of d2 */ { if (fabs(d2 [2] [1] [i] - d3) > 0.00001) goto Fail; d3 += 0.1; } /* L1 */ if ((L1 [0] != 2) || (L1 [1] != 3) || (L1 [2] != 0) || (L1 [3] != 0)) goto Fail; /* e3 */ if ((fabs(e3 [0] - 1.1) > 0.00001) || (fabs(e3 [1] - 2.2) > 0.00001) || (fabs(e3 [2] - 3.3) > 0.00001) || (fabs(e3 [3]) > 0.00001) || (fabs(e3 [4]) > 0.00001)) goto Fail; /* s1 */ if ((s1 [0].x != 1) || (s1 [0].y != 2) || (s1 [0].z != 3) || (fabs(s1 [0].a - 2.0) > 0.00001) || (fabs(s1 [0].b - 3.0) > 0.00001) || (fabs(s1 [0].c - 4.0) > 0.00001)) goto Fail; for (i = 1; i < 3; i++) if ((s1 [i].x != 0) || (s1 [i].y != 0) || (s1 [i].z != 0) || (fabs(s1 [i].a) > 0.00001) || (fabs(s1 [i].b) > 0.00001) || (fabs(s1 [i].c) > 0.00001)) goto Fail; /* s2 */ if ((s2 [0].ch1 != 'a') || (s2 [0].ch2 != 'b') || (s2 [1].ch1 != 'l') || (s2 [1].ch2 != 'm')) goto Fail; if ((fabs(s2 [0].d1 - 3.3) > 0.00001) || (fabs(s2 [0].d2 - 4.4) > 0.00001) || (fabs(s2 [1].d1 - 3.5) > 0.00001) || (fabs(s2 [1].d2 - 4.6) > 0.00001)) goto Fail; for (i = 2; i < 4; i++) if ((s2 [i].ch1 != 0) || (s2 [i].ch2 != 0) || (fabs(s2 [i].d1) > 0.00001) || (fabs(s2 [i].d2) > 0.00001)) goto Fail; printf ("Passed Conformance Test 4.6.4.2\n"); return; Fail: printf ("Failed Conformance Test 4.6.4.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.4.3.CC b/Tests/Conformance/C4.6.4.3.CC new file mode 100755 index 0000000..00ef722 --- /dev/null +++ b/Tests/Conformance/C4.6.4.3.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.4.2: Verify that subscripts work */ /* properly in initializers. */ #include #include char str1[] = "Hello, "; char str2[] = "*world."; char *str[] = {&str1[0], &str2[1]}; int tensor[3][3][3] = {0,1,2,3,4,5,6,7,8, 9,10,11,12,13,14,15,16,17, 18,19,20,21,22,23,24,25,26}; int *ip[27] = { &tensor[0][0][0], &tensor[0][0][1], &tensor[0][0][2], &tensor[0][1][0], &tensor[0][1][1], &tensor[0][1][2], &tensor[0][2][0], &tensor[0][2][1], &tensor[0][2][2], &tensor[1][0][0], &tensor[1][0][1], &tensor[1][0][2], &tensor[1][1][0], &tensor[1][1][1], &tensor[1][1][2], &tensor[1][2][0], &tensor[1][2][1], &tensor[1][2][2], &tensor[2][0][0], &tensor[2][0][1], &tensor[2][0][2], &tensor[2][1][0], &tensor[2][1][1], &tensor[2][1][2], &tensor[2][2][0], &tensor[2][2][1], &tensor[2][2][2] }; main() { int i; char st1[20],st2[20]; int fail = 0; strcpy(st1, str[0]); strcat(st1, str[1]); strcpy(st2, &str1[0]); strcat(st2, &str2[1]); if (strcmp(st1,st2) != 0) fail = 1; for (i = 0; i < 27; ++i) if (*ip[i] != i) fail = 1; if (fail) printf ("Failed Conformance Test 4.6.4.3\n"); else printf ("Passed Conformance Test 4.6.4.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.5.1.CC b/Tests/Conformance/C4.6.5.1.CC new file mode 100755 index 0000000..2131ab3 --- /dev/null +++ b/Tests/Conformance/C4.6.5.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.5.1: Verification of enumeration initializations */ static enum E1 { a, b, c } e1 = b; enum E2 { d, e } e2 = e; main () { enum E3 { f, g, h } e3 = f; { enum E3 e4 = e3; register enum E4 { i, j, k } e8 = j; enum E4 e5 = e8; enum E2 e6 = d; enum E1 e7 = e1; if ((e1 != b) || (e2 != e) || (e3 != f) || (e4 != f) || (e5 != j) || (e6 != d) || (e7 != b)) goto Fail; printf ("Passed Conformance Test 4.6.5.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.5.1\n"); } } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.6.1.CC b/Tests/Conformance/C4.6.6.1.CC new file mode 100755 index 0000000..c163b02 --- /dev/null +++ b/Tests/Conformance/C4.6.6.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.6.1: Verification of static and extern structure */ /* initialization */ #include #include struct S1 { int i; char ch; long L; float f; double d; extended e; unsigned int bf1: 8; }; struct S2 { int i1 [5]; char ch1 [10]; long L1 [3]; float f1 [4]; double d1 [3]; extended e1 [3]; unsigned int ui [4]; unsigned long ul [2]; }; struct S3 { struct S1 s1; struct S2 s2; }; /* Initialization of static & extern structures allowed; each variable */ /* within the structure is subject to the rules for initializing static */ /* and extern variables of the corresponding type. */ struct S1 s4 = { 32767, 'z', 32788, 17.0, 18.0, 19.0, 5 }; struct S2 s5 = { { 10, 20, 30, 40, 50 }, "ORCA/C !!", { 4, 5, 6 }, { 45.0, 55.0, 65.0, 75.0 }, { 455.0, 555.0, 655.0 }, { 4555.0, 5555.0 } }; struct S3 s6 = { { 7654, 'x', 65535, 876.0, 877.0, 878.0, 033 }, { { 10, 9, 8, 7, 6 }, "it's back", { 2000, 2001, 2002 }, { 7.7, 8.8, 9.9, 11.00 }, { 6.0, 6.0, 6.0 }, { 1.0, 1.3 }, { 0x7f, 0x80, 0x81, 0x82 }, { 0x01 } } }; main () { int i, j; long k; float f; double d; extended e; unsigned int ui; int TestStatics1 (void); int TestStatics2 (void); extern struct S1 s4; extern struct S2 s5; extern struct S3 s6; if ((s4.i != 32767) || (s4.ch != 'z') || (s4.L != 32788) || (s4.f != 17.0) || (s4.d != 18.0) || (s4.e != 19.0) || (s4.bf1 != 5)) goto Fail; for (j = 10, i = 0; i < 5; i++) { if (s5.i1 [i] != j) goto Fail; j += 10; } if (strcmp (s5.ch1, "ORCA/C !!")) goto Fail; for (k = 4, i = 0; i < 3; i++) if (s5.L1 [i] != k++) goto Fail; for (f = 45.0, i = 0; i < 4; i++) { if (s5.f1 [i] != f) goto Fail; f += 10.0; } for (d = 455.0, i = 0; i < 3; i++) { if (s5.d1 [i] != d) goto Fail; d += 100.0; } for (e = 4555.0, i = 0; i < 2; i++) { if (s5.e1 [i] != e) goto Fail; e += 1000.0; } for (i = 0; i < 4; i++) if (s5.ui [i] != 0) goto Fail; for (i = 0; i < 2; i++) if (s5.ul [i] != 0) goto Fail; if ((s6.s1.i != 7654) || (s6.s1.ch != 'x') || (s6.s1.L != 65535) || (s6.s1.f != 876.0) || (s6.s1.d != 877.0) || (s6.s1.e != 878.0) || (s6.s1.bf1 != 27)) goto Fail; for (j = 10, i = 0; i < 5; i++) if (s6.s2.i1 [i] != j--) goto Fail; if (strcmp (s6.s2.ch1, "it's back")) goto Fail; for (k = 2000, i = 0; i < 3; i++) if (s6.s2.L1 [i] != k++) goto Fail; for (f = 7.7, i = 0; i < 4; i++) { if ((s6.s2.f1 [i] - f) > 0.00001) goto Fail; f += 1.1; } for (d = 6.0, i = 0; i < 3; i++) if (s6.s2.d1 [i] != d) goto Fail; if ((s6.s2.e1 [0] != 1.0) || (s6.s2.e1 [1] != 1.3)) goto Fail; for (ui = 0x7F, i = 0; i < 4; i++) if (s6.s2.ui [i] != ui++) goto Fail; if ((s6.s2.ul [0] != 1) || (s6.s2.ul [1] != 0)) goto Fail; if (TestStatics1()) goto Fail; if (TestStatics2()) goto Fail; printf ("Passed Conformance Test 4.6.6.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.6.1\n"); } /******************************************************************************/ int TestStatics1 (void) { int i, j; long k; float f; double d; extended e; unsigned int ui; static struct S1 s1 = { 1, 'a', -2147483647, 4.3, 4.3e100, 4.3e300, 0xFF }; static struct S2 s2 = { { 1, 2, 3, 4, 5 }, "an array ", { 8, 9, 10 }, { 5.1, 5.2, 5.3, 5.4 }, { 5.1e50, 5.2e50, 5.3e50 }, { 5.1e200, 5.2e200, 5.3e200 }, { 0xFFFF, 0xFFFE, 0xFFFD } }; if ((s1.i != 1) || (s1.ch != 'a') || (s1.L != -2147483647) || (fabs(s1.f - 4.3) > 0.00001) || (fabs(s1.d - 4.3e100) > 1e95) || (s1.bf1 != 0xFF)) goto Fail; for (i = 0; i < 5; i++) if (s2.i1 [i] != i + 1) goto Fail; if (strcmp (s2.ch1, "an array ")) goto Fail; for (k = 8, i = 0; i < 3; i++) if (s2.L1 [i] != k++) goto Fail; for (f = 5.1, i = 0; i < 4; i++) { if (fabs(s2.f1 [i] - f) > 0.00001) goto Fail; f += 0.1; } for (d = 5.1e50, i = 0; i < 3; i++) { if (fabs(s2.d1 [i] - d) > 1e44) goto Fail; d += 0.1e50; } for (e = 5.1e200, i = 0; i < 2; i++) { if (fabs(s2.e1 [i] - e) > 1e195) goto Fail; e += 0.1e200; } for (ui = 0xFFFF, i = 0; i < 3; i++) if (s2.ui [i] != ui--) goto Fail; if ((s2.ui [3] != 0) || (s2.ul [0] != 0) || (s2.ul [1] != 0)) goto Fail; return 0; Fail: return 1; } /******************************************************************************/ int TestStatics2 (void) { int i, j; long k; float f; double d; extended e; unsigned int ui; static struct S3 s1 = { { 9, 'd', 80000, 88.9, 88.99, 888.999, 0x33 }, { { 9, 8, 7, 6, 5 }, "ten chars", { 32768, 32769, 32770 }, { 6.0, 7.0, 8.0, 9.0 }, { 66.0, 77.0, 88.0, }, { 666.0, 777.0 }, { 0x7FFF, } } }; if ((s1.s1.i != 9) || (s1.s1.ch != 'd') || (s1.s1.L != 80000) || (fabs(s1.s1.f - 88.9) > 0.0001) || (fabs(s1.s1.d - 88.99) > 0.0001) || (fabs(s1.s1.e - 888.999) > 0.001) || (s1.s1.bf1 != 0x33)) goto Fail; for (j = 9, i = 0; i < 5; i++) if (s1.s2.i1 [i] != j--) goto Fail; if (strcmp (s1.s2.ch1, "ten chars")) goto Fail; for (k = 32768, i = 0; i < 3; i++) if (s1.s2.L1 [i] != k++) goto Fail; for (f = 6.0, i = 0; i < 4; i++) { if (fabs(s1.s2.f1 [i] - f) > 0.00001) goto Fail; f += 1.0; } for (d = 66.0, i = 0; i < 3; i++) { if (fabs(s1.s2.d1 [i] - d) > 0.0001) goto Fail; d += 11.0; } for (e = 666.0, i = 0; i < 2; i++) { if (fabs(s1.s2.e1 [i] - e) > 0.001) goto Fail; e += 111.0; } if (s1.s2.ui [0] != 0x7FFF) goto Fail; for (i = 1; i < 4; i++) if (s1.s2.ui [i] != 0) goto Fail; for (i = 0; i < 2; i++) if (s1.s2.ul [i] != 0) goto Fail; return 0; Fail: return 1; } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.6.2.CC b/Tests/Conformance/C4.6.6.2.CC new file mode 100755 index 0000000..25f800a --- /dev/null +++ b/Tests/Conformance/C4.6.6.2.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.6.2: Verification of auto and register structure */ /* initialization */ #include #include struct S1 { int i; char ch; long L; float f; double d; extended e; unsigned int bf1: 8; }; struct S2 { int i1 [5]; char ch1 [10]; long L1 [3]; float f1 [4]; double d1 [3]; extended e1 [3]; unsigned int ui [4]; unsigned long ul [2]; }; struct S3 { struct S1 s1; struct S2 s2; }; main () { int i, j; long k; float f; double d; extended e; unsigned int ui; unsigned long ul; /* Initialization of auto and register structures allowed; each variable */ /* within the structure can only be set to a constant. */ register struct S1 s1 = { 1, 'a', -2147483647, 4.3, 4.3e100, 4.3e300, 0xFF }; register struct S2 s2 = { { 1, 2, 3, 4, 5 }, "an array ", { 8, 9, 10 }, { 5.1, 5.2, 5.3, 5.4 }, { 5.1e50, 5.2e50, 5.3e50 }, { 5.1e200, 5.2e200, 5.3e200 }, { 0xFFFF, 0xFFFE, 0xFFFD } }; register struct S3 s3 = { { 9, 'd', 80000, 88.9, 88.99, 888.999, 0x33 }, { { 9, 8, 7, 6, 5 }, "ten chars", { 32768, 32769, 32770 }, { 6.0, 7.0, 8.0, 9.0 }, { 66.0, 77.0, 88.0, }, { 666.0, 777.0 }, { 0x7FFF, } } }; struct S1 s4 = { 32767, 'z', 32788, 17.0, 18.0, 19.0, 5 }; struct S2 s5 = { { 10, 20, 30, 40, 50 }, "ORCA/C !!", { 4, 5, 6 }, { 45.0, 55.0, 65.0, 75.0 }, { 455.0, 555.0, 655.0 }, { 4555.0, 5555.0 } }; struct S3 s6 = { { 7654, 'x', 65535, 876.0, 877.0, 878.0, 033 }, { { 10, 9, 8, 7, 6 }, "it's back", { 2000, 2001, 2002 }, { 7.7, 8.8, 9.9, 11.0 }, { 6.0, 6.0, 6.0 }, { 1.0, 1.3 }, { 0x7f, 0x80, 0x81, 0x82 }, { 0x01 } } }; /* Check initialization of struct s1. */ if ((s1.i != 1) || (s1.ch != 'a') || (s1.L != -2147483647) || (fabs(s1.f - 4.3) > 0.00001) || (fabs(s1.d - 4.3e100) > 1e95) || (s1.bf1 != 0xFFu)) goto Fail; /* Check initialization of struct s2. */ for (i = 0; i < 5; i++) if (s2.i1 [i] != i + 1) goto Fail; if (strcmp (s2.ch1, "an array ")) goto Fail; for (k = 8, i = 0; i < 3; i++) if (s2.L1 [i] != k++) goto Fail; for (f = 5.1, i = 0; i < 4; i++) { if (fabs(s2.f1 [i] - f) > 0.00001) goto Fail; f += 0.1; } for (d = 5.1e50, i = 0; i < 3; i++) { if (fabs(s2.d1 [i] - d) > 1e45) goto Fail; d += 0.1e50; } for (e = 5.1e200, i = 0; i < 2; i++) { if (fabs(s2.e1 [i] - e) > 1e195) goto Fail; e += 0.1e200; } for (ui = 0xFFFF, i = 0; i < 3; i++) if (s2.ui [i] != ui--) goto Fail; if ((s2.ui [3] != 0) || (s2.ul [0] != 0) || (s2.ul [1] != 0)) goto Fail; /* Check initialization of struct s3. */ if ((s3.s1.i != 9) || (s3.s1.ch != 'd') || (s3.s1.L != 80000) || (fabs(s3.s1.f - 88.9) > 0.0001) || (fabs(s3.s1.d - 88.99) > 0.0001) || (fabs(s3.s1.e - 888.999) > 0.0001) || (s3.s1.bf1 != 0x33)) goto Fail; for (j = 9, i = 0; i < 5; i++) if (s3.s2.i1 [i] != j--) goto Fail; if (strcmp (s3.s2.ch1, "ten chars")) goto Fail; for (k = 32768, i = 0; i < 3; i++) if (s3.s2.L1 [i] != k++) goto Fail; for (f = 6.0, i = 0; i < 4; i++) { if (s3.s2.f1 [i] != f) goto Fail; f += 1.0; } for (d = 66.0, i = 0; i < 3; i++) { if (fabs(s3.s2.d1 [i] - d) > 0.0001) goto Fail; d += 11.0; } for (e = 666.0, i = 0; i < 2; i++) { if (fabs(s3.s2.e1 [i] - e) > 0.0001) goto Fail; e += 111.0; } if (s3.s2.ui [0] != 0x7FFF) goto Fail; for (i = 1; i < 4; i++) if (s3.s2.ui [i] != 0) goto Fail; for (i = 0; i < 2; i++) if (s3.s2.ul [i] != 0) goto Fail; /* Check initialization of struct s4. */ if ((s4.i != 32767) || (s4.ch != 'z') || (s4.L != 32788) || (fabs(s4.f - 17.0) > 0.00001) || (fabs(s4.d - 18.0) > 0.00001) || (fabs(s4.e - 19.0) > 0.00001) || (s4.bf1 != 5)) goto Fail; /* Check initialization of struct s5. */ for (j = 10, i = 0; i < 5; i++) { if (s5.i1 [i] != j) goto Fail; j += 10; } if (strcmp (s5.ch1, "ORCA/C !!")) goto Fail; for (k = 4, i = 0; i < 3; i++) if (s5.L1 [i] != k++) goto Fail; for (f = 45.0, i = 0; i < 4; i++) { if (fabs(s5.f1 [i] - f) > 0.0001) goto Fail; f += 10.0; } for (d = 455.0, i = 0; i < 3; i++) { if (fabs(s5.d1 [i] - d) > 0.0001) goto Fail; d += 100.0; } for (e = 4555.0, i = 0; i < 2; i++) { if (fabs(s5.e1 [i] - e) > 0.01) goto Fail; e += 1000.0; } for (i = 0; i < 4; i++) if (s5.ui [i] != 0) goto Fail; for (i = 0; i < 2; i++) if (s5.ul [i] != 0) goto Fail; /* Check initialization of struct s6. */ if ((s6.s1.i != 7654) || (s6.s1.ch != 'x') || (s6.s1.L != 65535) || (fabs(s6.s1.f - 876.0) > 0.001) || (fabs(s6.s1.d - 877.0) > 0.001) || (fabs(s6.s1.e - 878.0) > 0.001) || (s6.s1.bf1 != 27)) goto Fail; for (j = 10, i = 0; i < 5; i++) if (s6.s2.i1 [i] != j--) goto Fail; if (strcmp (s6.s2.ch1, "it's back")) goto Fail; for (k = 2000, i = 0; i < 3; i++) if (s6.s2.L1 [i] != k++) goto Fail; for (f = 7.7, i = 0; i < 4; i++) { if (fabs(s6.s2.f1 [i] - f) > 0.00001) goto Fail; f += 1.1; } for (d = 6.0, i = 0; i < 3; i++) if (s6.s2.d1 [i] != d) goto Fail; if ((fabs(s6.s2.e1 [0] - 1.0) > 0.00001) || (fabs(s6.s2.e1 [1] - 1.3) > 0.00001)) goto Fail; for (ui = 0x7F, i = 0; i < 4; i++) if (s6.s2.ui [i] != ui++) goto Fail; if ((s6.s2.ul [0] != 1) || (s6.s2.ul [1] != 0)) goto Fail; printf ("Passed Conformance Test 4.6.6.2\n"); return; Fail: printf ("Failed Conformance Test 4.6.6.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C4.6.7.1.CC b/Tests/Conformance/C4.6.7.1.CC new file mode 100755 index 0000000..42014f8 --- /dev/null +++ b/Tests/Conformance/C4.6.7.1.CC @@ -0,0 +1 @@ +/* Conformance Test 4.6.7.1: Verification of union initialization */ union U1 { int i; long L; float f; }; union U1 u1 = { 3 }; static union U1 u2 = 5; main () { auto union U1 u3 = { 32767 }; if (u1.i != 3) goto Fail; if (u2.i != 5) goto Fail; if (u3.i != 32767) goto Fail; printf ("Passed Conformance Test 4.6.7.1\n"); return; Fail: printf ("Failed Conformance Test 4.6.7.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C5.6.0.1.CC b/Tests/Conformance/C5.6.0.1.CC new file mode 100755 index 0000000..b631fab --- /dev/null +++ b/Tests/Conformance/C5.6.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 5.6.0.1: Make sure structs can be forward */ /* declared. */ #include int fail = 0; struct foo bar; struct foo {int i,j;}; void f(void) { struct foo {char j,k;} bar; bar.j = 'a'; bar.k = 'b'; if ((bar.j != 'a') || (bar.k != 'b')) fail = 1; } int main(void) { bar.i = -1; bar.j = 3; if ((bar.i != -1) || (bar.j != 3)) fail = 1; f(); if (fail) printf ("Failed Conformance Test 5.6.0.1\n"); else printf ("Passed Conformance Test 5.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C6.2.3.1.CC b/Tests/Conformance/C6.2.3.1.CC new file mode 100755 index 0000000..fbb0dd4 --- /dev/null +++ b/Tests/Conformance/C6.2.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 5.11.0.1: Verification of type equivalence: int types */ #include main () { char ch = 'Z'; int i = 80, k; short sh = 5; enum E { a, b, c } e = b; unsigned char uch = 'm'; unsigned int ui = 0xff; unsigned short ush = 0x80; static void TestCnv (unsigned int ch, unsigned int i, int ui); static int TestInt (int ch, int i, int e, int sh, int ui, int ush, int uch); static unsigned int TestUnsigned (unsigned int ush, unsigned int ui, unsigned int uch, unsigned int e, unsigned int sh, unsigned int i, unsigned int ch); k = TestInt (ch, i, e, sh, ui, ush, uch); if (k != 0x703) goto Fail; k = TestUnsigned (ush, ui, uch, e, sh, i, ch); if (k != 0x3739) goto Fail; ch = 131; i = -32767; ui = 0xa123; TestCnv (ch, i, ui); printf ("Passed Conformance Test 6.2.3.1\n"); return; Fail: printf ("Failed Conformance Test 6.2.3.1\n"); } /*****************************************************************************/ static int TestInt (int ch, int i, int e, int sh, int ui, int ush, int uch) { int j; /* Ensure parameters have not been changed during usual conversions. */ if ((ch != 90) || (i != 80) || (e != 1) || (sh != 5) || (ui != 255) || (ush != 128) || (uch != 109)) goto Fail; /* Compute integral expression and check expected result. */ j = (ch + i * e - ui / sh << 4 | ush >> 1) - (uch); if (j != 1795) goto Fail; return j; Fail: printf ("Failure in TestInt function in Conformance Test 5.11.0.1\n"); exit (-1); } /*****************************************************************************/ static unsigned int TestUnsigned (unsigned int ush, unsigned int ui, unsigned int uch, unsigned int e, unsigned int sh, unsigned int i, unsigned int ch) { unsigned int j; /* Ensure parameters have not been changed during usual conversions. */ if ((ush != 128) || (ui != 255) || (sh != 5) || (e != 1) || (i != 80) || (ch != 90) || (uch != 109)) goto Fail; /* Compute integral expression and check expected result. */ j = ((ush ^ e) * uch) - (ch / sh >> 2) + (i & ui); if (j != 14137) goto Fail; return j; Fail: printf ("Failure in TestUnsigned function in Conformance Test 6.2.3.1\n"); exit (-1); } /*****************************************************************************/ static void TestCnv (unsigned int ch, unsigned int i, int ui) { if ((ch != 0x0083) || (i != 0x8001) || (ui != -24285)) goto Fail; return; Fail: printf ("Failure in TestCnv function in Conformance Test 6.2.3.1\n"); exit (-1); } \ No newline at end of file diff --git a/Tests/Conformance/C6.2.3.2.CC b/Tests/Conformance/C6.2.3.2.CC new file mode 100755 index 0000000..e44f1bf --- /dev/null +++ b/Tests/Conformance/C6.2.3.2.CC @@ -0,0 +1 @@ +/* Conformance Test 6.2.3.2: Verification of type equivalence: long types */ #include main () { signed char ch; int i; short sh; long L = 2147483647; unsigned char uch; unsigned int ui; unsigned short ush; unsigned long uL; static long TestLong (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch); static void TestCnv (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch); L = TestLong (L, L, L, L, L, L, L, L); if (L != -2139095296) goto Fail; TestCnv (L, L, L, L, L, L, L, L); printf ("Passed Conformance Test 6.2.3.2\n"); return; Fail: printf ("Failed Conformance Test 6.2.3.2\n"); } /*****************************************************************************/ static long TestLong (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch) { long LL; /* Ensure parameters have not been changed during usual conversions. */ if ((uL != 0x7fFFffFF) || (ush != 0xffff) || (ui != 0xFFFF) || (uch != 0xff) || (L != 2147483647) || (sh != -1) || (i != -1) || (ch != -1)) goto Fail; /* Compute integral expression and check expected result. */ LL = (uL >> 8 ^ ush >> 8) - (L + ch * sh); if (LL != -2139095296) goto Fail; return LL; Fail: printf ("Failure in TestLong function in Conformance Test 6.2.3.2\n"); exit (-1); } /*****************************************************************************/ static void TestCnv (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch) { if ((uL != 0x807FFF00) || (ush != 0xFF00) || (ui != 0xFF00) || (uch != 0) || (L != -2139095296) || (sh != -256) || (i != -256) || (ch != 0)) goto Fail; return; Fail: printf ("Failure in TestCnv function in Conformance Test 6.2.3.2\n"); exit (-1); } \ No newline at end of file diff --git a/Tests/Conformance/C6.2.3.3.CC b/Tests/Conformance/C6.2.3.3.CC new file mode 100755 index 0000000..324844c --- /dev/null +++ b/Tests/Conformance/C6.2.3.3.CC @@ -0,0 +1 @@ +/* Conformance Test 6.2.3.3: Verification of type equivalence: long types */ #include main () { signed char ch; int i; short sh; long L; unsigned char uch; unsigned int ui; unsigned short ush; unsigned long uL = 65535; static long TestULong (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch); static void TestCnv (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch); uL = TestULong (uL, uL, uL, uL, uL, uL, uL, uL); if (uL != 0xffFf0000) goto Fail; TestCnv (uL, uL, uL, uL, uL, uL, uL, uL); printf ("Passed Conformance Test 6.2.3.3\n"); return; Fail: printf ("Failed Conformance Test 6.2.3.3\n"); } /*****************************************************************************/ static long TestULong (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch) { unsigned long UL; /* Ensure parameters have not been changed during usual conversions. */ if ((uL != 0x0000ffFF) || (ush != 0xffff) || (ui != 0xFFFF) || (uch != 0xff) || (L != 65535) || (sh != -1) || (i != -1) || (ch != -1)) goto Fail; /* Compute integral expression and check expected result. */ UL = ((uL >> 8 ^ ush >> 8) - (L + ch * sh)) | 0x80000000; if (UL != 0xFFFF0000) goto Fail; return UL; Fail: printf ("Failure in TestULong function in Conformance Test 6.2.3.3\n"); exit (-1); } /*****************************************************************************/ static void TestCnv (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch) { if ((uL != 0xFFFF0000) || (ush != 0) || (ui != 0) || (uch != 0) || (L != -65536) || (sh != 0) || (i != 0) || (ch != 0)) goto Fail; return; Fail: printf ("Failure in TestCnv function in Conformance Test 6.2.3.3\n"); exit (-1); } \ No newline at end of file diff --git a/Tests/Conformance/C6.2.3.4.CC b/Tests/Conformance/C6.2.3.4.CC new file mode 100755 index 0000000..7e22482 --- /dev/null +++ b/Tests/Conformance/C6.2.3.4.CC @@ -0,0 +1 @@ +/* Conformance Test 6.2.3.4: Verification of type equivalence: long types */ #include main () { signed char ch = 0x87; int i = -32767; short sh = -12345; long L; unsigned char uch = 0x95; unsigned int ui = 0xabcd; unsigned short ush = 0x8765; unsigned long uL; static long TestLong (long ush, long ui, long uch, long sh, long i, long ch); static unsigned long TestULong (unsigned long ush, unsigned long ui, unsigned long uch, unsigned long sh, unsigned long i, unsigned long ch); L = TestLong (ush, ui, uch, sh, i, ch); if (L != 3952611) goto Fail; uL = TestULong (ush, ui, uch, sh, i, ch); if (uL != 0xFFFE7BFA) goto Fail; printf ("Passed Conformance Test 6.2.3.4\n"); return; Fail: printf ("Failed Conformance Test 6.2.3.4\n"); } /*****************************************************************************/ static long TestLong (long ush, long ui, long uch, long sh, long i, long ch) { long L; /* Ensure parameters have not been changed during usual conversions. */ if ((ush != 0x8765) || (ui != 0xaBcD) || (uch != 149) || (sh != -12345) || (i != -32767) || (ch != -121)) goto Fail; /* Compute integral expression and check expected result. */ L = i * ch - ush / ui + uch + sh; if (L != 3952611) goto Fail; return L; Fail: printf ("Failure in TestLong function in Conformance Test 6.2.3.4\n"); exit (-1); } /*****************************************************************************/ static unsigned long TestULong (unsigned long ush, unsigned long ui, unsigned long uch, unsigned long sh, unsigned long i, unsigned long ch) { unsigned long ul; /* Check converted values passed to function. */ if ((ush != 0x8765) || (ui != 0xaBcD) || (uch != 0x95) || (sh != 0xFFFFcfc7) || (i != 0xffff8001) || (ch != 0xffffff87)) goto Fail; /* Use values to compute expression, and then check expected result. */ ul = ch - sh - ui - ush + i - uch; if (ul != 0xFFFE7BFA) goto Fail; return ul; Fail: printf ("Failure in TestULong function in Conformance Test 6.2.3.4\n"); exit (-1); } \ No newline at end of file diff --git a/Tests/Conformance/C7.10.0.1.CC b/Tests/Conformance/C7.10.0.1.CC new file mode 100755 index 0000000..6803e31 --- /dev/null +++ b/Tests/Conformance/C7.10.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.10.0.1: Verification of comma operator */ #include #include main () { int i = 5; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i = (i++ * 2, i -= 2, 88); L = (ch *= 2, ch--, 3000); ch = ('a' || 'b', ch++); c = -9, 888, f * 3.3; f = 1.1 + f, f -= 57, f+=1.0; d = (L, uch, -f); e = 8 + e, e -= 0.33, e / 2; ui = ui * 3, ui--, ui; ul = ul >>= 5, ul & 0x0, ul++; uch = (2 + uch, 'Y'); if ((i != 88) || (L != 3000) || (ch != 'A') || (ui != 1958) || (ul != 28) || (uch != 'Y') || (fabs(c -(- 9.0)) > 0.00001) || (fabs(f - (-51.4)) > 0.00001) || (fabs(d - 51.40) > 0.00001) || (fabs(e - 100.000) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.10.0.1\n"); return; Fail: printf ("Failed Conformance Test 7.10.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.4.1.1.CC b/Tests/Conformance/C7.4.1.1.CC new file mode 100755 index 0000000..1a4cad7 --- /dev/null +++ b/Tests/Conformance/C7.4.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.4.1.1: Verification of subscripted expressions */ #include #include main () { int i [5] = { 1, 2, 3, 4, 5 }, *iptr = i; struct S { float f; char ch; } s = { 2.2, 'k' }, *sptr = &s; static double D (extended e), (*fptr) () = D, d; if ((iptr++ [2]) != 3) goto Fail; if (iptr != &i [1]) goto Fail; if (i [4] != 5) goto Fail; d = (*fptr) (5.5); if (fabs(d - 11.0) > 0.00001) goto Fail; d = fptr (4.5); if (fabs(d - 9.0) > 0.00001) goto Fail; printf ("Passed Conformance Test 7.4.1.1\n"); return; Fail: printf ("Failed Conformance Test 7.4.1.1\n"); } /*****************************************************************************/ static double D (extended e) { return (e * 2.0); } \ No newline at end of file diff --git a/Tests/Conformance/C7.4.4.1.CC b/Tests/Conformance/C7.4.4.1.CC new file mode 100755 index 0000000..72ae3c8 --- /dev/null +++ b/Tests/Conformance/C7.4.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.4.4.1: Verification of postincrement operator */ #include #include main () { int i = 5, j; long L = 32777; char ch = 'y'; unsigned int ui = 65534; unsigned long ul = 0x7FFFFFFF; unsigned char uch = 0x80; comp c = 2147483646; float f = 3.5; double d = 87.65; extended e = 92.33; struct st {int i,j;} s[2]; i++; L++; ch++; ui++; ul++; uch++; c++; f++; d++; e++; if ((i != 6) || (L != 32778) || (ch != 'z') || (ui != 65535) || (ul != 0x80000000) || (uch != 0x81) || (c != 2147483647) || (fabs(f - 4.5) > 0.00001) || (fabs(d - 88.65) > 0.00001) || (fabs(e - 93.33) > 0.00001)) goto Fail; i = 1; s[1].j = 3; j = s[i].j++; if ((j != 3) || (s[i].j != 4)) goto Fail; printf ("Passed Conformance Test 7.4.4.1\n"); return; Fail: printf ("Failed Conformance Test 7.4.4.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.4.5.1.CC b/Tests/Conformance/C7.4.5.1.CC new file mode 100755 index 0000000..8aa3f49 --- /dev/null +++ b/Tests/Conformance/C7.4.5.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.4.5.1: Verification of postdecrement operator */ #include main () { int i = 5; long L = 32777; char ch = 'y'; unsigned int ui = 65534; unsigned long ul = 0x7FFFFFFF; unsigned char uch = 0x80; comp c = 4294967295ul; float f = 3.5; double d = 87.65; extended e = 92.33; i--; L--; ch--; ui--; ul--; uch--; c--; f--; d--; e--; if ((i != 4) || (L != 32776) || (ch != 'x') || (ui != 65533) || (ul != 0x7fFFffFE) || (uch != 0x7f) || (c != 4294967294ul) || (f != 2.5) || (d != 86.65) || (e != 91.33)) goto Fail; printf ("Passed Conformance Test 7.4.5.1\n"); return; Fail: printf ("Failed Conformance Test 7.4.5.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.1.1.CC b/Tests/Conformance/C7.5.1.1.CC new file mode 100755 index 0000000..4670034 --- /dev/null +++ b/Tests/Conformance/C7.5.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.1.1: Verification of type casting: int, char types */ #include main () { signed char ch = 'Z'; int i = 80, j, k [7]; short sh = 5; enum E { a, b, c } e = b; unsigned char uch = 'm'; unsigned int ui = 0xff, n [7]; unsigned short ush = 0x80; /* Conversion from integer to integer. */ k [0] = (int) ch; k [1] = (int) i; k [2] = (int) sh; k [3] = (int) ui; k [4] = (int) ush; k [5] = (int) uch; k [6] = (int) e; if ((k [0] != 90) || (k [1] != 80) || (k [2] != 5) || (k [3] != 255) || (k [4] != 128) || (k [5] != 109) || (k [6] != 1)) goto Fail; /* Conversion from integer to unsigned integer. */ n [0] = (unsigned int) ch; n [1] = (unsigned int) i; n [2] = (unsigned int) sh; n [3] = (unsigned int) ui; n [4] = (unsigned int) ush; n [5] = (unsigned int) uch; n [6] = (unsigned int) e; if ((n [4] != 128) || (n [3] != 255) || (n [2] != 5) || (n [6] != 1) || (n [1] != 80) || (n [0] != 90) || (n [5] != 109)) goto Fail; /* Test conversion from negative integer to unsigned integer. */ ch = -125; i = -32767; ui = 0xa123; n [0] = (unsigned int) ch; n [1] = (unsigned int) i; j = (int) ui; if ((n [0] != 0xFF83) || (n [1] != 0x8001) || (j != -24285)) goto Fail; printf ("Passed Conformance Test 7.5.1.1\n"); return; Fail: printf ("Failed Conformance Test 7.5.1.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.1.2.CC b/Tests/Conformance/C7.5.1.2.CC new file mode 100755 index 0000000..c5cc9a6 --- /dev/null +++ b/Tests/Conformance/C7.5.1.2.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.1.2: Verification of type casting: long types */ #include main () { signed char ch; int i; short sh; long L = 2147483647, LL; unsigned char uch; unsigned int ui; unsigned short ush; unsigned long uL; extern void TestCnv (unsigned long uL, unsigned short ush, unsigned int ui, unsigned char uch, long L, short sh, int i, signed char ch); /* Test conversion from long to other integral types. */ uL = (unsigned long) L; ush = (unsigned short) L; ui = (unsigned int) L; uch = (unsigned char) L; LL = (long) L; sh = (short) L; i = (int) L; ch = (signed char) L; if ((uL != 0x7fFFffFF) || (ush != 0xffff) || (ui != 0xFFFF) || (uch != 0xff) || (LL != 2147483647) || (sh != -1) || (i != -1) || (ch != -1)) goto Fail; L = -2139095040; uL = (unsigned long) L; ush = (unsigned short) L; ui = (unsigned int) L; uch = (unsigned char) L; LL = (long) L; sh = (short) L; i = (int) L; ch = (signed char) L; if ((uL != 0x80800000) || (ush != 0) || (ui != 0) || (uch != 0) || (LL != -2139095040) || (sh != 0) || (i != 0) || (ch != 0)) goto Fail; printf ("Passed Conformance Test 7.5.1.2\n"); return; Fail: printf ("Failed Conformance Test 7.5.1.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.1.3.CC b/Tests/Conformance/C7.5.1.3.CC new file mode 100755 index 0000000..bc5e295 --- /dev/null +++ b/Tests/Conformance/C7.5.1.3.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.1.3: Verification of type equivalence: long types */ #include main () { signed char ch; int i; short sh; long L; unsigned char uch; unsigned int ui; unsigned short ush; unsigned long ul = 65535, uLL; /* Test conversion from unsigned long to other integral types. */ uLL = (unsigned long) ul; ush = (unsigned short) ul; ui = (unsigned int) ul; uch = (unsigned char) ul; L = (long) ul; sh = (short) ul; i = (int) ul; ch = (signed char) ul; if ((uLL != 0x0000ffFF) || (ush != 0xffff) || (ui != 0xFFFF) || (uch != 0xff) || (L != 65535) || (sh != -1) || (i != -1) || (ch != -1)) goto Fail; ul = 0xffF20000; uLL = (unsigned long) ul; ush = (unsigned short) ul; ui = (unsigned int) ul; uch = (unsigned char) ul; L = (long) ul; sh = (short) ul; i = (int) ul; ch = (signed char) ul; if ((uLL != 0xFFF20000) || (ush != 0) || (ui != 0) || (uch != 0) || (L != -917504) || (sh != 0) || (i != 0) || (ch != 0)) goto Fail; printf ("Passed Conformance Test 7.5.1.3\n"); return; Fail: printf ("Failed Conformance Test 7.5.1.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.1.4.CC b/Tests/Conformance/C7.5.1.4.CC new file mode 100755 index 0000000..fd7792c --- /dev/null +++ b/Tests/Conformance/C7.5.1.4.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.1.4: Verification of type casting: int to long */ #include main () { signed char ch = 0x87; int i = -32767; short sh = -12345; long L [6]; unsigned char uch = 0x95; unsigned int ui = 0xabcd; unsigned short ush = 0x8765; unsigned long uL [6]; /* Test conversion from shorter integer to long. */ L [0] = (long) ush; L [1] = (long) ui; L [2] = (long) uch; L [3] = (long) sh; L [4] = (long) i; L [5] = (long) ch; if ((L [0] != 0x8765) || (L [1] != 0xaBcD) || (L [2] != 149) || (L [3] != -12345) || (L [4] != -32767) || (L [5] != -121)) goto Fail; /* Test conversion from shorter integer to unsigned long. */ uL [0] = (unsigned long) ush; uL [1] = (unsigned long) ui; uL [2] = (unsigned long) uch; uL [3] = (unsigned long) sh; uL [4] = (unsigned long) i; uL [5] = (unsigned long) ch; if ((uL [0] != 0x8765) || (uL [1] != 0xaBcD) || (uL [2] != 0x95) || (uL [3] != 0xFFFFcfc7) || (uL [4] != 0xffff8001) || (uL [5] != 0xffffff87)) goto Fail; printf ("Passed Conformance Test 7.5.1.4\n"); return; Fail: printf ("Failed Conformance Test 7.5.1.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.1.5.CC b/Tests/Conformance/C7.5.1.5.CC new file mode 100755 index 0000000..a65ec65 --- /dev/null +++ b/Tests/Conformance/C7.5.1.5.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.1.5: Verification of conversion from floating-point */ /* to integer types using type casting */ #include main () { char ch; short sh; int i; long L; unsigned char uch; unsigned int ui; unsigned long ul; float f [10] = { 123.456, -876.443, 456.789, -127.54, 321.456, -456.77, -844.0, 4.0, 6.0, 4.2e2 }, ff; double d [10] = { -1234.56, 4567.89977, 55555.66666, 4.5, -89.0, -4565.00, 333.88, 42.567, 76.564, 987.98765 }, dd; extended e [10] = { 8.456e20, 3478.6e-100, 9876.43E+300, 0.00e-30, 00.00, -0.0, 0.577, 00.33, 0.43212, 0.9876}, ee; /* Check conversion from float to other arithmetic types. */ ff = (float) f [0]; dd = (double) f [1]; ee = (extended) f [2]; ch = (char) f [3]; sh = (short) f [4]; i = (int) f [5]; L = (long) f [6]; uch = (unsigned char) f [7]; ui = (unsigned int) f [8]; ul = (unsigned long) f [9]; if ((ff != 123.456) || (dd != -876.443) || (ee != 456.789) || (ch != -127) || (sh != 321) || (i != -456) || (L != -844) || (uch != 4) || (ui != 6) || (ul != 420)) goto Fail; /* Check conversion from double to other arithmetic types. */ ff = (float) d [0]; dd = (double) d [1]; ee = (extended) d [2]; ch = (char) d [3]; sh = (short) d [4]; i = (int) d [5]; L = (long) d [6]; uch = (unsigned char) d [7]; ui = (unsigned int) d [8]; ul = (unsigned long) d [9]; if ((ff != -1234.56) || (dd != 4567.89977) || (ee != 55555.66666) || (ch != 4) || (sh != -89) || (i != -4565) || (L != 333) || (uch != 42) || (ui != 76) || (ul != 987)) goto Fail; /* Check conversion from extended to other arithmetic types. */ ff = (float) e [0]; dd = (double) e [1]; ee = (extended) e [2]; ch = (char) e [3]; sh = (short) e [4]; i = (int) e [5]; L = (long) e [6]; uch = (unsigned char) e [7]; ui = (unsigned int) e [8]; ul = (unsigned long) e [9]; if ((ff != 8.456e20) || (dd != 3478.6e-100) || (ee != 9876.43e+300) || (ch != 0) || (sh != 0) || (i != 0) || (L != 0) || (uch != 0) || (ui != 0) || (ul != 0)) goto Fail; printf ("Passed Conformance Test 7.5.1.5\n"); return; Fail: printf ("Passed Conformance Test 7.5.1.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.1.6.CC b/Tests/Conformance/C7.5.1.6.CC new file mode 100755 index 0000000..dda9c6f --- /dev/null +++ b/Tests/Conformance/C7.5.1.6.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.1.6: Verification of conversion from integer to */ /* floating-point types using type casting */ #include main () { char ch = 'D'; short sh = -32767; int i = 4456; long L = sh * 4; comp c = -(ch * i); unsigned char uch = 0x80; unsigned int ui = 65535; unsigned long ul = ui << 2; float f [8]; double d [8]; extended e [8]; /* Check conversion from integer to float. */ f [0] = (float) ch; f [1] = (float) sh; f [2] = (float) i; f [3] = (float) L; f [4] = (float) uch; f [5] = (float) ui; f [6] = (float) ul; f [7] = (float) c; if ((f [0] != 68.0) || (f [1] != -32767.0) || (f [2] != 4456.0) || (f [3] != -131068.0) || (f [4] != 128.0) || (f [5] != 65535.0) || (f [6] != 262140.0) || (f [7] != -303008.0)) goto Fail; /* Check conversion from double to other arithmetic types. */ d [0] = (double) ch; d [1] = (double) sh; d [2] = (double) i; d [3] = (double) L; d [4] = (double) uch; d [5] = (double) ui; d [6] = (double) ul; d [7] = (double) c; if ((d [0] != 68.0) || (d [1] != -32767.0) || (d [2] != 4456.0) || (d [3] != -131068.0) || (d [4] != 128.0) || (d [5] != 65535.0) || (d [6] != 262140.0) || (d [7] != -303008.0)) goto Fail; /* Check conversion from extended to other arithmetic types. */ e [0] = (extended) ch; e [1] = (extended) sh; e [2] = (extended) i; e [3] = (extended) L; e [4] = (extended) uch; e [5] = (extended) ui; e [6] = (extended) ul; e [7] = (extended) c; if ((e [0] != 68.0) || (e [1] != -32767.0) || (e [2] != 4456.0) || (e [3] != -131068.0) || (e [4] != 128.0) || (e [5] != 65535.0) || (e [6] != 262140.0) || (e [7] != -303008.0)) goto Fail; printf ("Passed Conformance Test 7.5.1.6\n"); return; Fail: printf ("Passed Conformance Test 7.5.1.6\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.5.1.CC b/Tests/Conformance/C7.5.5.1.CC new file mode 100755 index 0000000..3d7fc3c --- /dev/null +++ b/Tests/Conformance/C7.5.5.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.5.1: Verification of bitwise negation operator */ #include main () { char ch = 0x87; int i = -32767; short sh = -12345; long L = 2147483647; unsigned char uch = 0x95; unsigned int ui = 0xabcd; unsigned short ush = 0x8765; unsigned long uL = 0xffFFffaa; /* Invert each integer and check expected result. */ ch = ~ch; i = ~i; sh = ~sh; L = ~L; uch = ~uch; ui = ~ui; ush = ~ush; uL = ~uL; if ((ch != 'x') || (i != 32766) || (sh != 12344) || (L != 0x80000000) || (uch != 106) || (ui != 21554) || (ush != 0x789a) || (uL != 85)) goto Fail; printf ("Passed Conformance Test 7.5.5.1\n"); return; Fail: printf ("Failed Conformance Test 7.5.5.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.8.1.CC b/Tests/Conformance/C7.5.8.1.CC new file mode 100755 index 0000000..c253415 --- /dev/null +++ b/Tests/Conformance/C7.5.8.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.8.1: Verification of preincrement operator */ #include #include main () { int i = 5; long L = 32777; char ch = 'y'; unsigned int ui = 65534; unsigned long ul = 0x7FFFFFFF; unsigned char uch = 0x80; float f = 3.5; double d = 87.65; extended e = 92.33; ++i; ++L; ++ch; ++ui; ++ul; ++uch; ++f; ++d; ++e; if ((i != 6) || (L != 32778) || (ch != 'z') || (ui != 65535) || (ul != 0x80000000) || (uch != 0x81) || (fabs(f - 4.5) > 0.00001) || (fabs(d - 88.65) > 0.00001) || (fabs(e - 93.33) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.5.8.1\n"); return; Fail: printf ("Failed Conformance Test 7.5.8.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.5.9.1.CC b/Tests/Conformance/C7.5.9.1.CC new file mode 100755 index 0000000..e172b01 --- /dev/null +++ b/Tests/Conformance/C7.5.9.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.5.9.1: Verification of predecrement operator */ #include #include main () { int i = 5; long L = 32777; char ch = 'y'; unsigned int ui = 65534; unsigned long ul = 0x7FFFFFFF; unsigned char uch = 0x80; comp c = 4294967295ul; float f = 3.5; double d = 87.65; extended e = 92.33; --i; --L; --ch; --ui; --ul; --uch; --c; --f; --d; --e; if ((i != 4) || (L != 32776) || (ch != 'x') || (ui != 65533) || (ul != 0x7fFFffFE) || (uch != 0x7f) || (c != 4294967294ul) || (fabs(f - 2.5) > 0.00001) || (fabs(d - 86.65) > 0.00001) || (fabs(e - 91.33) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.5.9.1\n"); return; Fail: printf ("Failed Conformance Test 7.5.9.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.1.1.CC b/Tests/Conformance/C7.6.1.1.CC new file mode 100755 index 0000000..53a9b46 --- /dev/null +++ b/Tests/Conformance/C7.6.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.1.1: Verification of multiplication operator */ #include #include main () { int i = 5; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i = i * -8; L = 3 * L; ch = 2 * ch; c = -9 * c; f = 1.1 * f; d = d * 5; e = 8 * e; ui = ui * 3; ul = 7 * ul; uch = 2 * uch; if ((i != -40) || (L != 98331) || (ch != 'B') || (ui != 1959) || (ul != 6265) || (uch != 16) || (c != -38646) || (fabs(f - 3.85) > 0.00001) || (fabs(d - 438.25) > 0.00001) || (fabs(e - 738.64) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.6.1.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.1.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.1.2.CC b/Tests/Conformance/C7.6.1.2.CC new file mode 100755 index 0000000..10c0e13 --- /dev/null +++ b/Tests/Conformance/C7.6.1.2.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.1.2: Verification of division operator */ #include main () { int i = 5; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i = i / -1; L = L / L; ch = ch / 3; c = c / -9; f = f / f; d = d / 5; e = e / 1.0; ui = ui / 3; ul = ul / 5; uch = 2 / uch; if ((i != -5) || (L != 1) || (ch != '\v') || (ui != 217) || (ul != 179) || (uch != 0) || (c != -477) || (f != 1.0) || (d != 17.53) || (e != 92.33)) goto Fail; printf ("Passed Conformance Test 7.6.1.2\n"); return; Fail: printf ("Failed Conformance Test 7.6.1.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.1.3.CC b/Tests/Conformance/C7.6.1.3.CC new file mode 100755 index 0000000..b2a347c --- /dev/null +++ b/Tests/Conformance/C7.6.1.3.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.1.3: Verification of remainder operator */ #include main () { char ch = 87; int i = 32767; short sh = 12345; long L = 98765; unsigned char uch = 130; unsigned int ui = 3579; unsigned short ush = 15234; unsigned long uL = 863112; /* Apply remainder operation to each integer and check expected result. */ ch = ch % 2; i = i % 3; sh = sh % 4; L = L % 5; uch = uch % 7; ui = ui % 8; ush = ush % 9; uL = uL % 10; if ((ch != 1) || (i != 1) || (sh != 1) || (L != 0) || (uch != 4) || (ui != 3) || (ush != 6) || (uL != 2)) goto Fail; printf ("Passed Conformance Test 7.6.1.3\n"); return; Fail: printf ("Failed Conformance Test 7.6.1.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.2.1.CC b/Tests/Conformance/C7.6.2.1.CC new file mode 100755 index 0000000..29d5c30 --- /dev/null +++ b/Tests/Conformance/C7.6.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.2.1: Verification of additive operators */ #include #include main () { int i = 5; long L = 32777; signed char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i = i + -8; L = 3 + L; ch = 2 + ch; c = -9 + c; f = 1.1 + f; d = d + 5; e = 8 + e; ui = ui + 3; ul = 7 + ul; uch = 2 + uch; if ((i != -3) || (L != 32780) || (ch != '#') || (ui != 656) || (ul != 902) || (uch != 10) || (c != 4285) || (fabs(f - 4.6) > 0.00001) || (fabs(d - 92.65) > 0.00001) || (fabs(e - 100.33) > 0.00001)) goto Fail; i = i - (-2000); L = 33 - L; ch = -90 - ch; c = 0 - c; f = 6.8 - f; d = d - 72.1; e = 3.2 - e; ui = ui - 8; ul = 999 - ul; uch = uch - uch; if ((i != 1997) || (L != -32747) || (ch != -125) || (ui != 648) || (ul != 97) || (uch != 0) || (c != -4285) || (fabs(f - 2.2) > 0.00001) || (fabs(d - 20.55) > 0.00001) || (fabs(e + 97.13) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.6.2.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.3.1.CC b/Tests/Conformance/C7.6.3.1.CC new file mode 100755 index 0000000..9781265 --- /dev/null +++ b/Tests/Conformance/C7.6.3.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.3.1: Verification of shift operators */ #include main () { signed char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Shift each integer left and check expected result. */ ch = ch << 1; i = i << 2; sh = sh << 3; L = L << 4; uch = uch << 6; ui = ui << 7; ush = ush << 8; uL = uL << 9; if ((ch != -82) || (i != -20684) || (sh != -28512) || (L != 0xedCAb650) || (uch != 0xc0) || (ui != 0xe580) || (ush != 0x3400) || (uL != 0xeca86400)) goto Fail; /* Shift each integer right and check expected result. */ ch = ch >> 2; i = i >> 3; sh = sh >> 4; L = L >> 5; uch = uch >> 7; ui = ui >> 8; ush = ush >> 9; uL = uL >> 10; if ((ch != 0xFFEB) || (i != 0xF5e6) || (sh != 0xF90a) || (L != 0xff6e55b2) || (uch != 1) || (ui != 0xe5) || (ush != 0x1A) || (uL != 0x3B2A19)) goto Fail; printf ("Passed Conformance Test 7.6.3.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.3.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.4.1.CC b/Tests/Conformance/C7.6.4.1.CC new file mode 100755 index 0000000..cceafa4 --- /dev/null +++ b/Tests/Conformance/C7.6.4.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.4.1: Verification of relational operators */ #include main () { int i [3] = { 5, 6, 7 }, *i1ptr = i, *i2ptr = &i [2]; int j, k, m, n; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; /* Compare integers and test expected results. */ j = i [0] < i [2]; k = L <= c; m = uch >= ul; n = ch > ch; if ((j != 1) || (k != 0) || (m != 0) || (n != 0)) goto Fail; /* Compare floating point values and test expected results. */ j = f < d; k = e <= e; m = d > e; n = e >= f; if ((j != 1) || (k != 1) || (m != 0) || (n != 1)) goto Fail; /* Compare pointers and test expected results. */ j = i1ptr > i2ptr; k = i2ptr <= i1ptr; m = i2ptr > i1ptr; n = i1ptr >= i2ptr; if ((j != 0) || (k != 0) || (m != 1) || (n != 0)) goto Fail; printf ("Passed Conformance Test 7.6.4.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.4.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.6.1.CC b/Tests/Conformance/C7.6.6.1.CC new file mode 100755 index 0000000..6552dcb --- /dev/null +++ b/Tests/Conformance/C7.6.6.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.6.1: Verification of bitwise AND operator */ #include main () { char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Invert each integer and check expected result. */ ch = ch & 0x42; i = i & 0x1234; sh = sh & 0x4321; L = L & 0xa1b2c3d4; uch = uch & 0x77; ui = ui & 0x7373; ush = ush & 0xabcd; uL = uL & 0x12345678; if ((ch != 0x42) || (i != 0x204) || (sh != 0x200) || (L != 0xA0908344) || (uch != 3) || (ui != 0x4343) || (ush != 0x204) || (uL != 0x10345430)) goto Fail; printf ("Passed Conformance Test 7.6.6.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.6.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.7.1.CC b/Tests/Conformance/C7.6.7.1.CC new file mode 100755 index 0000000..af93a38 --- /dev/null +++ b/Tests/Conformance/C7.6.7.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.7.1: Verification of bitwise XOR operator */ #include main () { char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Perform exclusive OR operation on each integer; check expected result. */ ch = ch ^ 0x42; i = i ^ 0x1234; sh = sh ^ 0x4321; L = L ^ 0xa1b2c3d4; uch = uch ^ 0x77; ui = ui ^ 0x7373; ush = ush ^ 0xabcd; uL = uL ^ 0x12345678; if ((ch != 0x15) || (i != 0xB9F9) || (sh != 0x7135) || (L != 0x5f6e68b1) || (uch != 0xf4) || (ui != 0xb8b8) || (ush != 0xB9F9) || (uL != 0x8a42024a)) goto Fail; printf ("Passed Conformance Test 7.6.7.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.7.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.6.8.1.CC b/Tests/Conformance/C7.6.8.1.CC new file mode 100755 index 0000000..3177677 --- /dev/null +++ b/Tests/Conformance/C7.6.8.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.6.8.1: Verification of bitwise OR operator */ #include main () { char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Perform bitwise OR operation on each integer; check expected result. */ ch = ch | 0x42; i = i | 0x1234; sh = sh | 0x4321; L = L | 0xa1b2c3d4; uch = uch | 0x77; ui = ui | 0x7373; ush = ush | 0xabcd; uL = uL | 0x12345678; if ((ch != 0x57) || (i != 0xbbfd) || (sh != 0x7335) || (L != 0xfffeebf5) || (uch != 0xf7) || (ui != 0xFBFB) || (ush != 0xBBFD) || (uL != 0x9A76567A)) goto Fail; printf ("Passed Conformance Test 7.6.8.1\n"); return; Fail: printf ("Failed Conformance Test 7.6.8.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.7.1.1.CC b/Tests/Conformance/C7.7.1.1.CC new file mode 100755 index 0000000..458c3ce --- /dev/null +++ b/Tests/Conformance/C7.7.1.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.7.1.1: Verification of logical AND operator */ #include #include main () { int i [3] = { 5, 6, 7 }, *i1ptr = i, *i2ptr = &i [2]; int j, k, m, n; long L = 32777; char ch = '!'; enum E { a, b, c }; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; float f = 3.5; double d = 87.65; extended e = 92.33; /* Perform logical ANDs; test expected results. Left-to-right evaluation */ /* guaranteed. */ j = i [0] && i [2]; k = L && c; m = 0 && uch++; n = a && ch--; if ((j != 1) || (k != 1) || (m != 0) || (n != 0) || (uch != 8) || (ch != '!')) goto Fail; j = f && (!d); k = --e && ++L; m = d && f; n = 0 && f--; if ((j != 0) || (k != 1) || (m != 1) || (n != 0) || (fabs(e - 91.33) > 0.00001) || (L != 32778) || (fabs(f - 3.5) > 0.00001)) goto Fail; j = i1ptr && i2ptr; k = 0 && (--i2ptr); m = i2ptr && i1ptr++; n = i2ptr-- && 0; if ((j != 1) || (k != 0) || (m != 1) || (n != 0) || (*i1ptr != 6) || (*i2ptr != 6)) goto Fail; printf ("Passed Conformance Test 7.7.1.1\n"); return; Fail: printf ("Failed Conformance Test 7.7.1.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.7.2.1.CC b/Tests/Conformance/C7.7.2.1.CC new file mode 100755 index 0000000..a429640 --- /dev/null +++ b/Tests/Conformance/C7.7.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.7.2.1: Verification of logical OR operator */ #include #include main () { int i [3] = { 5, 6, 7 }, *i1ptr = i, *i2ptr = &i [2]; int j, k, m, n; long L = 32777; char ch = '!'; enum E { a, b, c }; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; float f = 3.5; double d = 87.65; extended e = 92.33; /* Perform logical ORs; test expected results. Left-to-right evaluation */ /* guaranteed. */ j = i [0] || i [2]; k = L || c; m = 0 || uch++; n = a || ch--; if ((j != 1) || (k != 1) || (m != 1) || (n != 1) || (uch != 9) || (ch != ' ')) goto Fail; j = (!f) || (!d); k = --e || ++L; m = d || f; n = 0 || a; if ((j != 0) || (k != 1) || (m != 1) || (n != 0) || (fabs(e - 91.33) > 0.00001) || (L != 32777)) goto Fail; j = i1ptr || f; k = 0 || (--i2ptr); m = d || i1ptr++; n = i2ptr-- || 0; if ((j != 1) || (k != 1) || (m != 1) || (n != 1) || (*i1ptr != 5) || (*i2ptr != 5)) goto Fail; printf ("Passed Conformance Test 7.7.2.1\n"); return; Fail: printf ("Failed Conformance Test 7.7.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.8.0.1.CC b/Tests/Conformance/C7.8.0.1.CC new file mode 100755 index 0000000..9110afe --- /dev/null +++ b/Tests/Conformance/C7.8.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.8.0.1: Verification of conditional expressions */ #include #include main () { int i [3] = { 5, 6, 7 }, *i1ptr = i, *i2ptr = &i [2], *i3ptr; long L = 32777; char ch = '!'; enum E { a, b, c }; struct S { int i; float f ;} s1 = { 1, 1.0 }, s2 = { 2, 2.2 }, s3; unsigned int ui = 653; unsigned long ul = 895; float f = 3.5; double d = 87.65; extended e = 92.33; /* Evaluate conditional expressions; check expected results. Ensure */ /* operation is right associative. */ e = f ? L * 2: ch ? d: ul ? s1.f + s2.i: ui; if (fabs(e - 65554.0) > 0.00001) goto Fail; i [1] = a ? *i1ptr * 2: (*i2ptr / 7); if ((i [0] != 5) || (i [1] != 1) || (i [2] != 7)) goto Fail; s3 = i1ptr ? s1 : s2; if ((s3.i != 1) || (s3.f != 1.0)) goto Fail; i3ptr = (L / 8) ? (i1ptr += 2): NULL; if ((*i3ptr != 7) || (i1ptr != &i [2])) goto Fail; printf ("Passed Conformance Test 7.8.0.1\n"); return; Fail: printf ("Failed Conformance Test 7.8.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.1.CC b/Tests/Conformance/C7.9.2.1.CC new file mode 100755 index 0000000..58983bc --- /dev/null +++ b/Tests/Conformance/C7.9.2.1.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.1: Verification of multiplication assign operator */ #include #include main () { int i = 5; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i *= -8; L *= 3; ch *= 2; c *= -9; f *= 1.1; d *= 5; e *= 8; ui *= 3; ul *= 7; uch *= 2; if ((i != -40) || (L != 98331) || (ch != 'B') || (ui != 1959) || (ul != 6265) || (uch != 16) || (c != -38646) || (fabs(f - 3.85) > 0.00001) || (fabs(d - 438.25) > 0.00001) || (fabs(e - 738.64) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.9.2.1\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.2.CC b/Tests/Conformance/C7.9.2.2.CC new file mode 100755 index 0000000..a5de7b5 --- /dev/null +++ b/Tests/Conformance/C7.9.2.2.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.2: Verification of division assign operator */ #include #include main () { int i = 5; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i /= -1; L /= L; ch /= 3; c /= -9; f /= f; d /= 5; e /= 1.0; ui /= 3; ul /= 5; uch /= 2; if ((i != -5) || (L != 1) || (ch != '\v') || (ui != 217) || (ul != 179) || (uch != 4) || (c != -477) || (fabs(f - 1.0) > 0.00001) || (fabs(d - 17.53) > 0.00001) || (fabs(e - 92.33) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.9.2.2\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.3.CC b/Tests/Conformance/C7.9.2.3.CC new file mode 100755 index 0000000..b3274e4 --- /dev/null +++ b/Tests/Conformance/C7.9.2.3.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.3: Verification of remainder assign operator */ #include main () { char ch = 87; int i = 32767; short sh = 12345; long L = 98765; unsigned char uch = 130; unsigned int ui = 3579; unsigned short ush = 15234; unsigned long uL = 863112; /* Apply remainder operation to each integer and check expected result. */ ch %= 2; i %= 3; sh %= 4; L %= 5; uch %= 7; ui %= 8; ush %= 9; uL %= 10; if ((ch != 1) || (i != 1) || (sh != 1) || (L != 0) || (uch != 4) || (ui != 3) || (ush != 6) || (uL != 2)) goto Fail; printf ("Passed Conformance Test 7.9.2.3\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.4.CC b/Tests/Conformance/C7.9.2.4.CC new file mode 100755 index 0000000..190dd6f --- /dev/null +++ b/Tests/Conformance/C7.9.2.4.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.4: Verification of additive assign operators */ #include #include main () { int i = 5; long L = 32777; char ch = '!'; unsigned int ui = 653; unsigned long ul = 895; unsigned char uch = 0x8; comp c = 4294; float f = 3.5; double d = 87.65; extended e = 92.33; i += -8; L += 3; ch += 2; c += -9; f += 1.1; d += 5; e += 8; ui += 3; ul += 7; uch += 2; if ((i != -3) || (L != 32780) || (ch != '#') || (ui != 656) || (ul != 902) || (uch != 10) || (c != 4285) || (fabs(f - 4.6) > 0.00001) || (fabs(d - 92.65) > 0.00001) || (fabs(e - 100.33) > 0.00001)) goto Fail; i -= (-2000); L -= 33; ch -= -90; c -= 0; f -= 6.8; d -= 72.1; e -= 3.2; ui -= 8; ul -= 900; uch -= uch; if ((i != 1997) || (L != 32747) || (ch != 125) || (ui != 648) || (ul != 2) || (uch != 0) || (c != 4285) || (fabs(f - (-2.2)) > 0.00001) || (fabs(d - 20.55) > 0.00001) || (fabs(e - 97.13) > 0.00001)) goto Fail; printf ("Passed Conformance Test 7.9.2.4\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.5.CC b/Tests/Conformance/C7.9.2.5.CC new file mode 100755 index 0000000..4c2a3d6 --- /dev/null +++ b/Tests/Conformance/C7.9.2.5.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.5: Verification of shift assign operators */ #include main () { signed char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Shift each integer left and check expected result. */ ch <<= 1; i <<= 2; sh <<= 3; L <<= 4; uch <<= 6; ui <<= 7; ush <<= 8; uL <<= 9; if ((ch != -82) || (i != -20684) || (sh != -28512) || (L != 0xedCAb650) || (uch != 0xc0) || (ui != 0xe580) || (ush != 0x3400) || (uL != 0xeca86400)) goto Fail; /* Shift each integer right and check expected result. */ ch >>= 2; i >>= 3; sh >>= 4; L >>= 5; uch >>= 7; ui >>= 8; ush >>= 9; uL >>= 10; if ((ch != 0xFFEB) || (i != 0xF5e6) || (sh != 0xF90a) || (L != 0xff6e55b2) || (uch != 1) || (ui != 0xe5) || (ush != 0x1A) || (uL != 0x3B2A19)) goto Fail; printf ("Passed Conformance Test 7.9.2.5\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.6.CC b/Tests/Conformance/C7.9.2.6.CC new file mode 100755 index 0000000..36de4c8 --- /dev/null +++ b/Tests/Conformance/C7.9.2.6.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.6: Verification of bitwise AND assign operator */ #include main () { char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Invert each integer and check expected result. */ ch &= 0x42; i &= 0x1234; sh &= 0x4321; L &= 0xa1b2c3d4; uch &= 0x77; ui &= 0x7373; ush &= 0xabcd; uL &= 0x12345678; if ((ch != 0x42) || (i != 0x204) || (sh != 0x200) || (L != 0xA0908344) || (uch != 3) || (ui != 0x4343) || (ush != 0x204) || (uL != 0x10345430)) goto Fail; printf ("Passed Conformance Test 7.9.2.6\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.6\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.7.CC b/Tests/Conformance/C7.9.2.7.CC new file mode 100755 index 0000000..50708b2 --- /dev/null +++ b/Tests/Conformance/C7.9.2.7.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.7: Verification of bitwise XOR assign operator */ #include main () { char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Perform exclusive OR operation on each integer; check expected result. */ ch ^= 0x42; i ^= 0x1234; sh ^= 0x4321; L ^= 0xa1b2c3d4; uch ^= 0x77; ui ^= 0x7373; ush ^= 0xabcd; uL ^= 0x12345678; if ((ch != 0x15) || (i != 0xB9F9) || (sh != 0x7135) || (L != 0x5f6e68B1) || (uch != 0xf4) || (ui != 0xb8b8) || (ush != 0xB9F9) || (uL != 0x8a42024a)) goto Fail; printf ("Passed Conformance Test 7.9.2.7\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.7\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.8.CC b/Tests/Conformance/C7.9.2.8.CC new file mode 100755 index 0000000..581d095 --- /dev/null +++ b/Tests/Conformance/C7.9.2.8.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.8: Verification of bitwise OR assign operator */ #include main () { char ch = 0X57; int i = 0xabcd; short sh = 0x3214; long L = 0xfedcab65; unsigned char uch = 0x83; unsigned int ui = 0xcbcb; unsigned short ush = 0x1234; unsigned long uL = 0x98765432; /* Perform bitwise OR operation on each integer; check expected result. */ ch |= 0x42; i |= 0x1234; sh |= 0x4321; L |= 0xa1b2c3d4; uch |= 0x77; ui |= 0x7373; ush |= 0xabcd; uL |= 0x12345678; if ((ch != 0x57) || (i != 0xbbfd) || (sh != 0x7335) || (L != 0xfffeebf5) || (uch != 0xf7) || (ui != 0xFBFB) || (ush != 0xBBFD) || (uL != 0x9A76567A)) goto Fail; printf ("Passed Conformance Test 7.9.2.8\n"); return; Fail: printf ("Failed Conformance Test 7.9.2.8\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C7.9.2.9.CC b/Tests/Conformance/C7.9.2.9.CC new file mode 100755 index 0000000..ef97aea --- /dev/null +++ b/Tests/Conformance/C7.9.2.9.CC @@ -0,0 +1 @@ +/* Conformance Test 7.9.2.9: Make sure types can be mixed across the */ /* compound assignment operators. */ #include #include main () { int i,j; char str[] = "How, now, brown cow."; i = strlen(str); j = 0; j += strlen(str); if (i == j) printf ("Passed Conformance Test 7.9.2.9\n"); else printf ("Failed Conformance Test 7.9.2.9\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.7.0.1.CC b/Tests/Conformance/C8.7.0.1.CC new file mode 100755 index 0000000..10f1819 --- /dev/null +++ b/Tests/Conformance/C8.7.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 8.7.0.1: Verification of switch statement */ #include /****************************************************************************/ int F1 (int i) { switch (i) { case 1: return 9; case 2: return 99; case 3: return 999; default: return 9999; } } /****************************************************************************/ main () { char ch = 'd'; int i = 3; short s = 5; long L = 0; unsigned int ui = 0x7F; enum Colors { red, black, gold, green } color = gold; switch (i * s) /* test "fall through" of case labels */ { case 15: ++L; case 1: ++L; case 2: ++L; default: ++L; } if (L != 4) goto Fail; switch (ch >> i) /* test break out with goto statement */ { case 1: L = 1; case 2: L = 2; case 12: L = 12; goto Out; default: L = 0; } Out: if (L != 12) goto Fail; switch (s) /* test break out with break statement */ { case 1: L = 1; case 2: L = 2; case 3: L = 3; case 4: L = 4; case 5: L = 5; break; default: L = 0; } if (L != 5) goto Fail; switch (F1 (i)) /* test break out with return statement */ { case 999: L = 999; break; default: L = 0; } if (L != 999) goto Fail; switch (2) /* test no case labels equal switch */ { /* expr and no default given */ case 0: L = 0; case 1: L = 1; } if (L != 999) goto Fail; switch (ui) /* multiple case labels + default on */ { /* same statement */ case 0x7c: L = 0x7c; break; case 0x7e: case 0x7F: case 0x80: default: L = 0x80; break; case 0x7D: L = 0x7d; break; } if (L != 128) goto Fail; { enum Colors { red, black, gold, green } color = gold; switch (color) /* test nested switch statements */ { case red: switch (ui && i) { case 1: L = 1; break; case 0: L = 0; break; } break; case black: switch (--i) { case 2: L = 2; break; } break; case gold: switch (color) { case gold: L = (long) (color); } break; } if (L != 2) goto Fail; } printf ("Passed Conformance Test 8.7.0.1\n"); return; Fail: printf ("Failed Conformance Test 8.7.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.7.0.2.CC b/Tests/Conformance/C8.7.0.2.CC new file mode 100755 index 0000000..d94262b --- /dev/null +++ b/Tests/Conformance/C8.7.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 8.7.0.2: Test compact integer switch statement */ #include void main(void) { int i, sum1 = 0, sum2 = 0; for (i = 1; i < 11; i++) switch (i) { case 1: case 3: case 5: case 7: case 9: sum1 += i; break; case 2: case 4: case 6: case 8: sum2 += i; } if ((sum1 == 25) && (sum2 == 20)) printf ("Passed Conformance Test 8.7.0.2\n"); else printf ("Failed Conformance Test 8.7.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.7.0.3.CC b/Tests/Conformance/C8.7.0.3.CC new file mode 100755 index 0000000..7f6f350 --- /dev/null +++ b/Tests/Conformance/C8.7.0.3.CC @@ -0,0 +1 @@ +/* Conformance Test 8.7.0.3: Make sure negative numbers are accepted */ /* in switch */ #include void main(void) { int i, sum1 = 0, sum2 = 0; for (i = -11; i < 0; i++) switch (i) { case -1: case -3: case -5: case -7: case -9: sum1 += i; break; case -2: case -4: case -6: case -8: sum2 += i; } if ((sum1 == -25) && (sum2 == -20)) printf ("Passed Conformance Test 8.7.0.3\n"); else printf ("Failed Conformance Test 8.7.0.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.7.0.4.CC b/Tests/Conformance/C8.7.0.4.CC new file mode 100755 index 0000000..5698aba --- /dev/null +++ b/Tests/Conformance/C8.7.0.4.CC @@ -0,0 +1 @@ +/* Conformance Test 8.7.0.4: Make sure enums are accepted in switch */ #include void main(void) { enum color {red, orange, yellow, green, blue, violet} c; int primary = 0; for (c = red; c <= violet; c++) switch (c) { case red: case yellow: case blue: primary++; } if (primary == 3) printf ("Passed Conformance Test 8.7.0.4\n"); else printf ("Failed Conformance Test 8.7.0.4\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.7.0.5.CC b/Tests/Conformance/C8.7.0.5.CC new file mode 100755 index 0000000..e10ee08 --- /dev/null +++ b/Tests/Conformance/C8.7.0.5.CC @@ -0,0 +1 @@ +/* Conformance Test 8.7.0.5: Test sparse switch statements */ #include void main(void) { int i, hundreds = 0; for (i = 0; i < 1000; i += 10) switch (i) { case 100: case 200: case 300: case 400: case 500: case 600: case 700: case 800: case 900: hundreds++; } if (hundreds == 9) printf ("Passed Conformance Test 8.7.0.5\n"); else printf ("Failed Conformance Test 8.7.0.5\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.7.0.6.CC b/Tests/Conformance/C8.7.0.6.CC new file mode 100755 index 0000000..e37cdc8 --- /dev/null +++ b/Tests/Conformance/C8.7.0.6.CC @@ -0,0 +1 @@ +/* Conformance Test 8.7.0.6: Test swicth statements with long */ /* expressions */ #include void main(void) { long l; int hundreds = 0; for (l = 0; l < 1000000; l += 10000) switch (l) { case 100000: case 200000: case 300000: case 400000: case 500000: case 600000: case 700000: case 800000: case 900000: hundreds++; } if (hundreds == 9) printf ("Passed Conformance Test 8.7.0.6\n"); else printf ("Failed Conformance Test 8.7.0.6\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C8.8.0.1.CC b/Tests/Conformance/C8.8.0.1.CC new file mode 100755 index 0000000..9a665b2 --- /dev/null +++ b/Tests/Conformance/C8.8.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 8.8.0.1: Verification of break, continue statements */ #include #define youStillCan 1 main () { int F1 (int i, int j); int i = 65, j = 7, k; while (i > 0) /* test break, continue in while loop */ { j++; if (j == 15) break; if (((i - j) == 57) || ((i - j) == 55) || ((i - j) == 52)) continue; i--; } if ((i != 60) || (j != 15)) goto Fail; do /* test break, continue in do loop */ { i -= 2; if (((i / 2) == 29) || ((i / 2) == 27) || ((i / 2) == 25)) continue; j -= 3; if (j < 2) break; } while (youStillCan); if ((i != 44) || (j != 0)) goto Fail; for (k = 100; k > 0; k -= 5) /* test break, continue in for loop */ { if (k > 80) continue; if (k == 60) break; k -= 5; j += 2; } if ((j != 4) || (k != 60)) goto Fail; while ( (i = F1 (k, j)) > 57) /* test nested while, do, for, switch */ { do { for (; i > 60; i -= 4) { i /= 4; switch (i) { case 17: k -= 1; break; case 16: j -= 2; break; default: k -= 5; break; } if (k > 40) continue; } /* end for */ j -= 2; if (j == 0) break; } while (1); if (k == 45) continue; k -= 3; } if ((k != 57) || (j != 0) || (i != 57)) goto Fail; printf ("Passed Conformance Test 8.8.0.1\n"); return; Fail: printf ("Failed Conformance Test 8.8.0.1\n"); } /****************************************************************************/ int F1 (int i, int j) { return i + j; } \ No newline at end of file diff --git a/Tests/Conformance/C9.2.0.1.CC b/Tests/Conformance/C9.2.0.1.CC new file mode 100755 index 0000000..3e3ec3b --- /dev/null +++ b/Tests/Conformance/C9.2.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 9.2.0.1: Make sure pascal functions can be called. */ #include pascal int pasFunc (int i, int j) { return i+j; } void main(void) { if (pasFunc(2,5) != 7) goto Fail; if (pasFunc(3,0) != 3) goto Fail; if (pasFunc(8,1) != 9) goto Fail; if (pasFunc(1,1) != 2) goto Fail; printf ("Passed Conformance Test 9.2.0.1\n"); return; Fail: printf ("Failed Conformance Test 9.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C9.3.0.1.CC b/Tests/Conformance/C9.3.0.1.CC new file mode 100755 index 0000000..59982d2 --- /dev/null +++ b/Tests/Conformance/C9.3.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 9.3.0.1: Parameters, functions must be defined in time */ /* to call the function recursively. */ #include int iexp (int x, int y) { if (x == 0) return 1; if (y <= 1) return x; return iexp(x,y-1)*x; } void main(void) { if (iexp(2,5) != 32) goto Fail; if (iexp(3,3) != 27) goto Fail; if (iexp(1,50) != 1) goto Fail; if (iexp(7,3) != 343) goto Fail; printf ("Passed Conformance Test 9.3.0.1\n"); return; Fail: printf ("Failed Conformance Test 9.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C9.5.0.1.CC b/Tests/Conformance/C9.5.0.1.CC new file mode 100755 index 0000000..7a7fde2 --- /dev/null +++ b/Tests/Conformance/C9.5.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 9.5.0.1: Verification of parameter passing conventions */ #include #include struct S { int i; float f; comp c [5]; }; union U { int i; long L; }; /****************************************************************************/ void Func1 (int i, char ch [], float f, struct S s, union U u) { int j; for (j = 0; j < i; j++) /* alter array's contents */ ch [j] = (char) (j + 0x41); s.i = 22; /* this should not change struct's contents */ s.f = 8.0; s.c [0] = s.c [1] = s.c [2] = s.c [3] = s.c [4] = 32767; u.L = 2147483647l; /* this should not change unions's contents */ f = 9.9; /* this should not change float's contents */ } /****************************************************************************/ main () { char string [4] = "hey"; struct S s = { 1, 2.0, 1, 2, 3, 4, 5 }; union U u = { 9 }; float f = 0.5; Func1 (3, string, f, s, u); /* call function to change only array */ if (strcmp (string, "ABC")) goto Fail; if ((s.i != 1) || (fabs(s.f - 2.0) > 0.00001) || (s.c [0] != 1) || (s.c [1] != 2) || (s.c [2] != 3) || (s.c [3] != 4) || (s.c [4] != 5)) goto Fail; if ((u.i != 9) || (fabs(f - 0.5) > 0.00001)) goto Fail; printf ("Passed Conformance Test 9.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 9.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C9.5.0.2.CC b/Tests/Conformance/C9.5.0.2.CC new file mode 100755 index 0000000..b559a71 --- /dev/null +++ b/Tests/Conformance/C9.5.0.2.CC @@ -0,0 +1 @@ +/* Conformance Test 9.5.0.2: Make sure assignments can be used as parms */ #include int func (int x) { return x*2; } void main(void) { int i,j; i = j = 0; i = func(j = 3); if (i != 6) goto Fail; if (j != 3) goto Fail; printf ("Passed Conformance Test 9.5.0.2\n"); return; Fail: printf ("Failed Conformance Test 9.5.0.2\n"); } \ No newline at end of file diff --git a/Tests/Conformance/C9.7.0.1.CC b/Tests/Conformance/C9.7.0.1.CC new file mode 100755 index 0000000..bb1e68f --- /dev/null +++ b/Tests/Conformance/C9.7.0.1.CC @@ -0,0 +1 @@ +/* Conformance Test 9.7.0.1: Verification of function return types: enum, */ /* pointer to array, pointer to function, struct, */ /* and union */ #include #include #include struct S { float f; extended e; }; union U { double d; extended e; }; enum E { a, b, c }; /**************************************************************************/ void V1 (void) { } /**************************************************************************/ main () { /* Func1 returns an enumeration E constant. */ static enum E Func1 (char ch, int i, double d, struct S s); /* Func2 returns a pointer to an array of integers. */ static int ( *Func2 (long L, extended e, enum E e0) ) []; /* Func3 returns a pointer to a function returning void. */ static void ( *Func3 (union U u, unsigned long ul1) ) (); /* Func4 returns a struct S. */ static struct S Func4 (extended e, unsigned short s, float f); /* Func5 returns a union U. */ static union U Func5 (struct S s, double d, char ch, comp c); extended e = 8.88e-2; double d = 47.81; float f = 32.32; comp c = 222222; long L = 33769; char ch = 'k'; int i = 897; enum E e0 = b; int (*j)[], (*m)[], k; unsigned short sh = 0177; unsigned long ul1 = 0x11001100; struct S s = { 5.5, 6.6 }; union U u = 4.5; void (*funcPtr) (void); e0 = Func1 (ch, i, d, s); /* call functions & test return values */ if (e0 != a) goto Fail; m = j = Func2 (L, e, e0); if (j == NULL) goto Fail; for (k = 0; k < 5; k++) if ((*j)[k] != k) goto Fail; free (m); funcPtr = Func3 (u, ul1); if (funcPtr != V1) goto Fail; s = Func4 (e, sh, f); if ((fabs(s.f - 2340.0) > 0.01) || (fabs(s.e - (-159.4088)) > 0.001)) goto Fail; u = Func5 (s, d, ch, c); if (fabs(u.e - 123.456e+300) > 1e295) goto Fail; printf ("Passed Conformance Test 9.7.0.1\n"); return; Fail: printf ("Failed Conformance Test 9.7.0.1\n"); } /**************************************************************************/ static enum E Func1 (char ch, int i, double d, struct S s) { d = s.f - 0.5; if (d != 5.0) goto Fail; i += ch; if (i != 1004) goto Fail; return a; Fail: printf ("Failure in Conformance Test 9.7.0.1, Func1\n"); exit (-1); } /**************************************************************************/ static int ( *Func2 (long L, extended e, enum E e0) ) [] { int (*i)[], *j, k; e += ((extended) (L) - (extended) (e0)); /* check passed parameters */ if (fabs(e - 33769.0888) > 0.00001) goto Fail; i = (int (*)[]) calloc (5, sizeof (int)); /* create array to return */ if (i == NULL) goto Fail; for (j = *i, k = 0; k < 5; k++, j++) *j = k; return (i); Fail: printf ("Failure in Conformance Test 9.7.0.1, Func2\n"); exit (-1); } /**************************************************************************/ static void ( *Func3 (union U u, unsigned long ul1) ) () { extended e; e = (extended) (u.d) + (extended) (ul1); if (e != 285217028.5) goto Fail; return V1; Fail: printf ("Failure in Conformance Test 9.7.0.1, Func3\n"); exit (-1); } /**************************************************************************/ static struct S Func4 (extended e, unsigned short s, float f) { double d; struct S *SS; d = - ((double) (e)) - ((double) (s)) - ((double) (f)); /* test parms */ if (fabs(d - (-159.4088)) > 0.00001) goto Fail; /* Create struct to return. */ SS = (struct S *) calloc (1, sizeof (struct S)); if (SS == NULL) goto Fail; SS->f = 23.4e+02; SS->e = d; return * SS; Fail: printf ("Failure in Conformance Test 9.7.0.1, Func4\n"); exit (-1); } /**************************************************************************/ static union U Func5 (struct S s, double d, char ch, comp c) { extended e; comp cp; union U *u; e = s.f - d; /* test parameters */ if (fabs(e - 2292.19) > 0.01) goto Fail; cp = (comp) ch + c; if (cp != 222329) goto Fail; u = (union U *) calloc (1, sizeof (union U)); /* create union to return */ if (u == NULL) goto Fail; u->e = 123.456E+300; return (*u); Fail: printf ("Failure in Conformance Test 9.7.0.1, Func5\n"); exit (-1); } \ No newline at end of file diff --git a/Tests/Conformance/TEST b/Tests/Conformance/TEST new file mode 100755 index 0000000..f8a10dd --- /dev/null +++ b/Tests/Conformance/TEST @@ -0,0 +1 @@ +unset exit echo {1} cmpl -i {1} keep=3/t >>3/temp if {status} == 0 3/t else echo Could not compile {1} end \ No newline at end of file diff --git a/Tests/Conformance/TEST2 b/Tests/Conformance/TEST2 new file mode 100755 index 0000000..a665cd5 --- /dev/null +++ b/Tests/Conformance/TEST2 @@ -0,0 +1 @@ +echo {1} echo #pragma keep "3/t" >3/{1} echo #pragma memorymodel 1 >>3/{1} echo #pragma optimize -1 >>3/{1} echo >>3/{1} type {1} >>3/{1} change 3/{1} cc unset exit cmpl -i 3/{1} >>3/temp if {status} == 0 3/t else echo Could not compile {1} end if {#} == 1 delete 3/{1} end \ No newline at end of file diff --git a/Tests/Conformance/c14.4.0.1.cc b/Tests/Conformance/c14.4.0.1.cc new file mode 100755 index 0000000..491dd21 --- /dev/null +++ b/Tests/Conformance/c14.4.0.1.cc @@ -0,0 +1 @@ +/* Conformance Test 14.4.0.1: Verification of isgraph, isprint, ispunct */ #include main () { int i, j; char ch; unsigned char uc; /* isgraph: returns 0 if char is not in [ASCII 33 .. 126] */ /* isprint: returns 0 if char is not in [ASCII 32 .. 126] */ /* ispunct: returns 0 if char not in [ !"#$%&'()*+,-./:;<=>?@[\]^_`{|}~] */ j = isprint (' '); if (j == 0) goto Fail; for (ch = 33; ch < 127; ch++) { j = isgraph (ch); if (j == 0) goto Fail; j = isprint (ch); if (j == 0) goto Fail; } for (uc = '!'; uc < '0'; uc++) /* ! through / */ { j = ispunct (uc); if (j == 0) goto Fail; } for (uc = ':'; uc < 'A'; uc++) /* : thru @ */ { j = ispunct (uc); if (j == 0) goto Fail; } for (ch = '['; ch < 'a'; ch++) /* [ thru ` */ { j = ispunct (ch); if (j == 0) goto Fail; } for (uc = 0x7B; uc < 127; uc++) /* { thru ~ */ { j = ispunct (uc); if (j == 0) goto Fail; } for (i = 0; i < 32; i++) /* 0 for non-set characters */ { j = isgraph ((char) i); if (j != 0) goto Fail; j = isprint ((char) i); if (j != 0) goto Fail; j = ispunct ((char) i); if (j != 0) goto Fail; } if (ispunct(' ')) goto Fail; printf ("Passed Conformance Test 14.4.0.1\n"); return; Fail: printf ("Failed Conformance Test 14.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/c19.5.0.1.cc b/Tests/Conformance/c19.5.0.1.cc new file mode 100755 index 0000000..976f84e --- /dev/null +++ b/Tests/Conformance/c19.5.0.1.cc @@ -0,0 +1 @@ +/* Conformance Test 19.5.0.1: Verification of frexp, ldexp, modf functions */ #include main () { double d1, d2; int i; d1 = frexp (4.8, &i); if ((fabs(d1 - .60) > 0.00001) || (i != 3)) goto Fail; d1 = frexp (0, &i); if ((fabs(d1) > 0.00001) || (i != 0)) goto Fail; d1 = ldexp (3.2, 4); if (fabs(d1 - 51.2) > 0.00001) goto Fail; d1 = modf (-14.654, &d2); if ((fabs(d1 - (-0.654)) > 0.00001) || (d2 != -14.0)) goto Fail; printf ("Passed Conformance Test 19.5.0.1\n"); return; Fail: printf ("Failed Conformance Test 19.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/c24.0.3.cc b/Tests/Conformance/c24.0.3.cc new file mode 100755 index 0000000..f390dd8 --- /dev/null +++ b/Tests/Conformance/c24.0.3.cc @@ -0,0 +1 @@ +/* Conformance Test 24.0.3: Test the use of the extended character set */ #pragma lint -1 #include #include typedef enum {false, true} boolean; void main (void) { boolean fail; int a, b, c, i; char str[128]; int €‘‚’ƒ“„”´Ä…•µ†–¶Æ‡—§·ˆ˜¸Ø‰™¹Šš‹›»ËŒœ¼Ì½ÍŽž®¾ÎÞŸ¯¿Ïß; int €‘‚’ƒ“„”´Ä…•µ†„ÆƇ—§·Ë˜¸Ø‰™¹€…Ìͻ˜¼Ì‚½Íƒž®®ÎÞ†¯¯Îß; /* Make sure alpha-"looking" characters are allowed in identifiers, and that the lowercase versions are distinct from the uppercase versions. */ fail = false; €‘‚’ƒ“„”´Ä…•µ†–¶Æ‡—§·ˆ˜¸Ø‰™¹Šš‹›»ËŒœ¼Ì½ÍŽž®¾ÎÞŸ¯¿Ïß = 4; €‘‚’ƒ“„”´Ä…•µ†„ÆƇ—§·Ë˜¸Ø‰™¹€…Ìͻ˜¼Ì‚½Íƒž®®ÎÞ†¯¯Îß = 5; if (€‘‚’ƒ“„”´Ä…•µ†–¶Æ‡—§·ˆ˜¸Ø‰™¹Šš‹›»ËŒœ¼Ì½ÍŽž®¾ÎÞŸ¯¿Ïß != 4) fail = true; /* Make sure all special characters are allowed in strings */ strcpy(str, ""); for (i = 17; i <= 20; ++i) if (str[i - 17] != i) { fail = true; printf("Character %d was incorrect in str.\n", i); } strcpy(str, "€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«" "¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×Ø"); for (i = 128; i <= 216; ++i) if (str[i - 128] != i) { fail = true; printf("Character %d was incorrect in str.\n", i); } if ('Þ' != 222) { fail = true; printf("Character 222 was incorrect in str.\n"); } if ('ß' != 223) { fail = true; printf("Character 223 was incorrect in str.\n"); } /* Make sure all special characters are allowed in comments */ /* The special character set is: 0 1 2 3 4 5 6 7 8 9 A B C D E F 0 0 @ P ` p €   ° À Ð 1  ! 1 A Q a q ‘ ¡ ± Á Ñ 2  " 2 B R b r ‚ ’ ¢ ² Â Ò 3  # 3 C S c s ƒ “ £ ³ Ã Ó 4  $ 4 D T d t „ ” ¤ ´ Ä Ô 5 % 5 E U e u … • ¥ µ Å Õ 6 & 6 F V f v † – ¦ ¶ Æ Ö 7 ' 7 G W g w ‡ — § · Ç × 8 ( 8 H X h x ˆ ˜ ¨ ¸ È Ø 9 ) 9 I Y i y ‰ ™ © ¹ É A * 0 J Z j z Š š ª º Ê B + : K [ k { ‹ › « » Ë C , ; L \ l | Œ œ ¬ ¼ Ì D _ < M ] m } ­ ½ Í E . = N ^ n ~ Ž ž ® ¾ Î Þ F / ? O _ o Ÿ ¯ ¿ Ï ß */ /* Make sure the special operators work */ /* Some lines also test the non-breaking space */ aÊ=Ê100; bÊ=Ê3; cÊ=ÊaÖb; ifÊ(aʲÊb) fail = true; if (! (a ² a)) fail = true; if (b ³ a) fail = true; if (! (b ³ b)) fail = true; if (c ­ 33) fail = true; c = a Ç 2; if (c ­ 400) fail = true; c = a È 2; if (c ­ 25) fail = true; if (!fail) printf("Passed Conformance Test 24.0.3\n"); else printf("Failed Conformance Test 24.0.3\n"); } \ No newline at end of file diff --git a/Tests/Conformance/c26.0.1.cc b/Tests/Conformance/c26.0.1.cc new file mode 100755 index 0000000..4f7e06d --- /dev/null +++ b/Tests/Conformance/c26.0.1.cc @@ -0,0 +1 @@ +/* Conformance Test 26.0.1: Ensure can include all library header files */ /* without conflicts */ #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include main () { printf ("Passed Conformance Test 26.0.1\n"); } \ No newline at end of file diff --git a/Tests/Conformance/c6.2.3.5.cc b/Tests/Conformance/c6.2.3.5.cc new file mode 100755 index 0000000..e52ed53 --- /dev/null +++ b/Tests/Conformance/c6.2.3.5.cc @@ -0,0 +1 @@ +/* Conformance Test 6.2.3.5: Verification of conversion from floating-point */ /* to integer types */ #include #include main () { float f; double d; extended e; static float F (float f, double d, extended e, signed char ch, short sh, int i, long L, unsigned char uch, unsigned int ui, unsigned long ul); static double D (float f, double d, extended e, signed char ch, short sh, int i, long L, unsigned char uch, unsigned int ui, unsigned long ul); static extended E (float f, double d, extended e, signed char ch, short sh, int i, long L, unsigned char uch, unsigned int ui, unsigned long ul); #if 0 f = F (123.456, -876.443, 456.789, -127.54, 321.456, -456.77, -844.0, 4.0, 6.0, 4.2e2); if (fabs(f - 18.224) > 0.00001) goto Fail; #endif d = D (-1234.56, 4567.89977, 55555.66666, 4.5, -89.0, -4565.00, 333.88, 42.567, 76.564, 987.98765); if (fabs(d - 28121.32696) > 0.00001) goto Fail; e = E (8.456e20, 3478.6e-100, 9876.43E+300, 0.00e-30, 00.00, -0.0, 0.577, 00.33, 0.43212, 0.9876); if (fabs(e) > 0.00001) goto Fail; printf ("Passed Conformance Test 6.2.3.5\n"); return; Fail: printf ("Passed Conformance Test 6.2.3.5\n"); } /******************************************************************************/ static float F (float f, double d, extended e, signed char ch, short sh, int i, long L, unsigned char uch, unsigned int ui, unsigned long ul) { float f1; /* Check expected values of passed parameters. */ if ((fabs(f - 123.456) > 0.00001) || (fabs(d - (-876.443)) > 0.00001) || (fabs(e - 456.789) > 0.00001) || (ch != -127) || (sh != 321) || (i != -456) || (L != -844) || (uch != 4) || (ui != 6) || (ul != 420)) goto Fail; /* Calculate a float value to return, and check expected result. */ f1 = f + d - e + (sh / ch + i - L / uch * ui + ul); if (fabs(f1 - 18.224) > 0.0001) goto Fail; return f1; Fail: printf ("Failure in F function in Conformance Test 6.2.3.5\n"); exit (-1); } /******************************************************************************/ static double D (float f, double d, extended e, signed char ch, short sh, int i, long L, unsigned char uch, unsigned int ui, unsigned long ul) { double d1; /* Check expected values of passed parameters. */ if ((fabs(f - (-1234.56)) > 0.00001) || (fabs(d - 4567.89977) > 0.00001) || (fabs(e - 55555.66666) > 0.00001) || (ch != 4) || (sh != -89) || (i != -4565) || (L != 333) || (uch != 42) || (ui != 76) || (ul != 987)) goto Fail; /* Calculate a double value to return, and check expected result. */ d1 = e - d - f - (i / ch + ul / uch * sh - L * ui); if (fabs(d1 + 4294886577.673110) > 0.00001) goto Fail; return d1; Fail: printf ("Failure in D function in Conformance Test 6.2.3.5\n"); exit (-1); } /******************************************************************************/ static extended E (float f, double d, extended e, signed char ch, short sh, int i, long L, unsigned char uch, unsigned int ui, unsigned long ul) { extended e1; e1 = F (8.456e20, 3478.6e-100, 9876.43E+300, 0.00e-30, 00.00, -0.0, 0.577, 00.33, 0.43212, 0.9876); if ((fabs(f - 8.456e20) > 0.00001) || (fabs(d - 3478.6e-100) > 0.00001) || (fabs(e - 9876.43e+300) > 0.00001) || (ch != 0) || (sh != 0) || (i != 0) || (L != 0) || (uch != 0) || (ui != 0) || (ul != 0)) goto Fail; e1 = f / d * ch - ul; if (fabs(e1) > 0.00001) goto Fail; return (e1); Fail: printf ("Failure in E function in Conformance Test 6.2.3.5\n"); exit (-1); } \ No newline at end of file diff --git a/Tests/Conformance/doit b/Tests/Conformance/doit new file mode 100755 index 0000000..5428f68 --- /dev/null +++ b/Tests/Conformance/doit @@ -0,0 +1 @@ +{1} C2.1.0.1.CC {1} C2.1.0.2.CC {1} C2.1.0.3.CC {1} C2.1.0.4.CC {1} C2.1.1.1.CC {1} C2.1.1.2.CC {1} C2.1.2.1.CC {1} C2.1.2.2.CC {1} C2.1.2.3.CC {1} C2.2.0.1.CC {1} C2.2.0.2.CC {1} C2.2.0.3.CC {1} C2.2.0.4.CC {1} C2.4.0.1.CC {1} C2.4.0.2.CC {1} C2.5.0.1.CC {1} C2.5.0.2.CC {1} C2.5.0.3.CC {1} C2.5.0.4.CC {1} C2.5.0.5.CC {1} C2.5.0.6.CC {1} C2.5.0.7.CC {1} C2.5.0.8.CC {1} C2.6.0.1.CC {1} C2.6.0.2.CC {1} C2.6.0.3.CC {1} C2.6.0.4.CC {1} C2.6.0.5.CC {1} C2.7.1.1.CC {1} C2.7.1.2.CC {1} C2.7.1.3.CC {1} C2.7.1.4.CC {1} C2.7.1.5.CC {1} C2.7.1.6.CC {1} C2.7.1.7.CC {1} C2.7.1.8.CC {1} C2.7.2.1.CC {1} C2.7.2.2.CC {1} C2.7.2.3.CC {1} C2.7.3.1.CC {1} C2.7.3.2.CC {1} C2.7.4.1.CC {1} C2.7.4.2.CC {1} C2.7.4.3.CC {1} C2.7.4.4.CC {1} C2.7.7.1.CC {1} C2.7.7.2.CC {1} C3.3.0.1.CC {1} C3.3.1.1.CC {1} C3.3.2.1.CC {1} C3.3.3.1.CC {1} C3.3.4.1.CC {1} C3.3.5.1.CC {1} C3.3.6.1.CC {1} C3.3.8.1.CC {1} C3.3.9.1.CC {1} C3.5.1.1.CC {1} C3.5.1.2.CC {1} C3.5.1.3.CC {1} C3.5.1.4.CC {1} C3.5.1.5.CC {1} C3.5.2.1.CC {1} C3.5.2.2.CC {1} C3.5.2.3.CC {1} C3.5.2.4.CC {1} C3.5.3.1.CC {1} C3.5.4.1.CC {1} C3.5.4.2.CC {1} C4.2.1.1.CC {1} C4.2.2.1.CC {1} C4.2.4.1.CC {1} C4.2.5.1.CC {1} C4.3.0.1.CC {1} C4.3.0.2.CC {1} C4.4.2.1.CC {1} C4.5.2.1.CC {1} C4.5.2.2.CC {1} C4.5.2.3.CC {1} C4.5.3.1.CC {1} C4.5.3.2.CC {1} C4.5.3.3.CC {1} C4.5.3.4.CC {1} C4.5.4.1.CC {1} C4.5.4.2.CC {1} C4.6.1.1.CC {1} C4.6.1.2.CC {1} C4.6.2.1.CC {1} C4.6.2.2.CC {1} C4.6.3.1.CC {1} C4.6.3.2.CC {1} C4.6.4.1.CC {1} C4.6.4.2.CC {1} C4.6.5.1.CC {1} C4.6.6.1.CC {1} C4.6.6.2.CC {1} C4.6.7.1.CC {1} C5.6.0.1.CC {1} C6.2.3.1.CC {1} C6.2.3.2.CC {1} C6.2.3.3.CC {1} C6.2.3.4.CC {1} C6.2.3.5.CC {1} C7.4.1.1.CC {1} C7.4.4.1.CC {1} C7.4.5.1.CC {1} C7.5.1.1.CC {1} C7.5.1.2.CC {1} C7.5.1.3.CC {1} C7.5.1.4.CC {1} C7.5.1.5.CC {1} C7.5.1.6.CC {1} C7.5.5.1.CC {1} C7.5.8.1.CC {1} C7.5.9.1.CC {1} C7.6.1.1.CC {1} C7.6.1.2.CC {1} C7.6.1.3.CC {1} C7.6.2.1.CC {1} C7.6.3.1.CC {1} C7.6.4.1.CC {1} C7.6.6.1.CC {1} C7.6.7.1.CC {1} C7.6.8.1.CC {1} C7.7.1.1.CC {1} C7.7.2.1.CC {1} C7.8.0.1.CC {1} C7.9.2.1.CC {1} C7.9.2.2.CC {1} C7.9.2.3.CC {1} C7.9.2.4.CC {1} C7.9.2.5.CC {1} C7.9.2.6.CC {1} C7.9.2.7.CC {1} C7.9.2.8.CC {1} C7.10.0.1.CC {1} C8.7.0.1.CC {1} C8.7.0.2.CC {1} C8.7.0.3.CC {1} C8.7.0.4.CC {1} C8.7.0.5.CC {1} C8.7.0.6.CC {1} C8.8.0.1.CC {1} C9.2.0.1.CC {1} C9.3.0.1.CC {1} C9.5.0.1.CC {1} C9.5.0.2.CC {1} C9.7.0.1.CC {1} C13.1.0.1.CC {1} C14.1.0.1.CC {1} C14.2.0.1.CC {1} C14.3.0.1.CC {1} C14.4.0.1.CC {1} C14.5.0.1.CC {1} C14.6.0.1.CC {1} C14.7.0.1.CC {1} C14.8.0.1.CC {1} C14.9.0.1.CC {1} C15.1.0.1.CC {1} C15.2.0.1.CC {1} C15.3.0.1.CC {1} C15.5.0.1.CC {1} C15.6.0.1.CC {1} C15.7.0.1.CC {1} C15.7.0.2.CC {1} C15.8.0.1.CC {1} C15.8.0.2.CC {1} C15.9.0.1.CC {1} C16.1.0.1.CC {1} C16.4.0.1.CC {1} C17.5.0.1.CC {1} C17.5.0.2.CC {1} C17.6.0.1.CC {1} C17.6.0.2.CC {1} C17.7.0.1.CC {1} C17.7.0.2.CC {1} C17.8.0.1.CC {1} C17.8.0.2.CC {1} C17.8.0.3.CC {1} C17.8.0.4.CC {1} C17.8.0.5.CC {1} C17.8.0.6.CC {1} C17.8.0.7.CC {1} C17.8.0.8.CC {1} C17.8.0.9.CC {1} C17.8.0.10.CC {1} C17.8.0.11.CC {1} C17.8.0.12.CC {1} C17.8.0.13.CC {1} C17.8.0.14.CC {1} C17.8.0.15.CC {1} C17.8.0.16.CC {1} C17.8.0.17.CC {1} C17.8.0.18.CC {1} C17.8.0.19.CC {1} C17.8.0.20.CC {1} C17.8.0.21.CC {1} C17.8.0.22.CC {1} C17.8.0.23.CC {1} C17.8.0.24.CC {1} C17.9.0.1.CC {1} C17.10.0.1.CC {1} C17.11.0.1.CC {1} C17.11.0.2.CC {1} C17.11.0.3.CC {1} C17.11.0.4.CC {1} C17.11.0.5.CC {1} C17.11.0.6.CC {1} C17.11.0.7.CC {1} C17.11.0.8.CC {1} C17.11.0.9.CC {1} C17.11.0.10.CC {1} C17.11.0.11.CC {1} C17.13.0.1.CC {1} C17.14.0.1.CC {1} C17.15.0.1.CC {1} C17.16.0.1.CC {1} C18.1.0.1.CC {1} C18.3.0.1.CC {1} C19.1.0.1.CC {1} C19.2.0.1.CC {1} C19.3.0.1.CC {1} C19.4.0.1.CC {1} C19.5.0.1.CC {1} C19.6.0.1.CC {1} C19.7.0.1.CC {1} C19.8.0.1.CC {1} C19.9.0.1.CC {1} C19.10.0.1.CC {1} C20.1.0.1.CC {1} C20.5.0.1.CC {1} C21.1.0.2.CC {1} C21.4.0.1.CC {1} C22.5.0.1.CC {1} C23.1.0.1.CC {1} C23.2.0.1.CC {1} C23.3.0.1.CC {1} C23.4.0.1.CC {1} C23.5.0.1.CC {1} C23.6.0.1.CC {1} C24.0.1.CC {1} C24.0.2.CC {1} C24.0.3.CC {1} C25.0.1.CC {1} C25.0.2.CC {1} C25.0.3.CC {1} C25.0.4.CC {1} C25.0.5.CC {1} C25.0.6.CC {1} C25.0.7.CC {1} C25.0.8.CC {1} C25.0.9.CC {1} C25.0.10.CC {1} C25.0.11.CC {1} C25.0.12.CC {1} C25.0.13.CC {1} C25.0.14.CC {1} C25.0.15.CC {1} C25.0.16.CC {1} C25.0.17.CC {1} C25.0.18.CC {1} C25.0.19.CC {1} C25.0.20.CC {1} C25.0.21.CC {1} C25.0.22.CC {1} C25.0.23.CC {1} C25.0.24.CC {1} C25.0.25.CC {1} C25.0.26.CC {1} C26.0.1.CC \ No newline at end of file diff --git a/Tests/Conformance/doit2 b/Tests/Conformance/doit2 new file mode 100755 index 0000000..aa17288 --- /dev/null +++ b/Tests/Conformance/doit2 @@ -0,0 +1 @@ +{1} C17.14.0.1.CC {1} C17.15.0.1.CC {1} C17.16.0.1.CC {1} C18.1.0.1.CC {1} C18.3.0.1.CC {1} C19.1.0.1.CC {1} C19.2.0.1.CC {1} C19.3.0.1.CC {1} C19.4.0.1.CC {1} C19.5.0.1.CC {1} C19.6.0.1.CC {1} C19.7.0.1.CC {1} C19.8.0.1.CC {1} C19.9.0.1.CC {1} C19.10.0.1.CC {1} C20.1.0.1.CC {1} C20.5.0.1.CC {1} C21.1.0.2.CC {1} C21.4.0.1.CC {1} C22.5.0.1.CC {1} C23.1.0.1.CC {1} C23.2.0.1.CC {1} C23.3.0.1.CC {1} C23.4.0.1.CC {1} C23.5.0.1.CC {1} C23.6.0.1.CC {1} C24.0.1.CC {1} C24.0.2.CC {1} C24.0.3.CC {1} C25.0.1.CC {1} C25.0.2.CC {1} C25.0.3.CC {1} C25.0.4.CC {1} C25.0.5.CC {1} C25.0.6.CC {1} C25.0.7.CC {1} C25.0.8.CC {1} C25.0.9.CC {1} C25.0.10.CC {1} C25.0.11.CC {1} C25.0.12.CC {1} C25.0.13.CC {1} C25.0.14.CC {1} C25.0.15.CC {1} C25.0.16.CC {1} C25.0.17.CC {1} C25.0.18.CC {1} C25.0.19.CC {1} C25.0.20.CC {1} C25.0.21.CC {1} C25.0.22.CC {1} C25.0.23.CC {1} C25.0.24.CC {1} C25.0.25.CC {1} C25.0.26.CC {1} C26.0.1.CC \ No newline at end of file diff --git a/Tests/Deviance/D2.1.0.1.CC b/Tests/Deviance/D2.1.0.1.CC new file mode 100755 index 0000000..4b63636 --- /dev/null +++ b/Tests/Deviance/D2.1.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.1.0.1: Ensure graphic characters $, @, ` can only appear */ /* in comments and character and string constants. */ main () { int hey$, you@, look`; } \ No newline at end of file diff --git a/Tests/Deviance/D2.2.0.2.CC b/Tests/Deviance/D2.2.0.2.CC new file mode 100755 index 0000000..2bc5d99 --- /dev/null +++ b/Tests/Deviance/D2.2.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 2.2.0.2: Ensure comments without terminators are flagged */ /* as errors */ main () { /* don't terminate this one int a; */ and then try to comment here */ a = 3; printf ("Failed Deviance Test 2.2.0.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.4.0.1.CC b/Tests/Deviance/D2.4.0.1.CC new file mode 100755 index 0000000..0ef56d7 --- /dev/null +++ b/Tests/Deviance/D2.4.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.4.0.1: Ensure compound operators are scanned as one token */ main () { struct a { int b; } structA, *sptr; int i, j; i = 1; j = 2; /* Test compound assignment operators. */ i + = j; i - = j; i * = j; i / = j; i % = j; i << = j; i >> = j; i & = j; i ^ = j; i | = j; /* Test other compound operators. */ sptr = &structA; sptr- >b = 5; i + +; j - -; i = i < < j; j = i > > j; if (i < = j) ; if ( (i <= j) | | (j >= i) ) ; if (j > = i) ; if ( (i <= j) || (j >= i) & & (i == 3) ) ; if (i = = 3) ; if (j ! = 5) ; printf ("Failed Deviance Test 2.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.5.0.1.CC b/Tests/Deviance/D2.5.0.1.CC new file mode 100755 index 0000000..47fd52c --- /dev/null +++ b/Tests/Deviance/D2.5.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.5.0.1: Ensure error flagging for invalid identifiers */ main () { int 1n; char !v_9; char @wrk; char #et; long $hex; long %percent; long ^caret; long &ersand; short *asterisk8876_L6, mid(_00; short middle)paren; float -minus; float +plus; float eq=ual; double {curly; extended brack}et; extern int square[; extern comp qu"ote; static unsigned char ]bracket; static unsigned short t'ic; extern long lessthan; float quest?ion; double period.; extern float ti~lde; int gra`ve; long bar|; unsigned char back\slash; char sla/sh; printf ("Failed Deviance Test 2.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.5.0.2.CC b/Tests/Deviance/D2.5.0.2.CC new file mode 100755 index 0000000..6ba5560 --- /dev/null +++ b/Tests/Deviance/D2.5.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 2.5.0.2: Ensure reserved words cannot be used as identifiers */ main () { int auto; int break; int case; int char; int continue; int default; int do; int double; long else; long enum; long extern; long float; long for; long goto; long if; long int; float long; float register; float return; float short; float sizeof; float static; float struct; float switch; double typedef; double union; double unsigned; double void; double while; short const; short signed; short volatile; unsigned asm; unsigned comp; unsigned extended; unsigned inline; unsigned pascal; unsigned segment; printf ("Failed Deviance Test 2.5.0.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.1.1.CC b/Tests/Deviance/D2.7.1.1.CC new file mode 100755 index 0000000..9cb8e69 --- /dev/null +++ b/Tests/Deviance/D2.7.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.1.1: Ensure misformed integers are flagged as errors */ main () { int a; a = 32t79; /* invalid character embedded in digit sequence */ a = 14f; /* floating-pt type marker only used with reals */ a = 28F; a = 12FA; /* decimal number with embedded hex digits */ a = 04FC; /* octal number with embedded hex digits */ /* octal number with more than 255 characters */ a = 000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000003; /* hex number with more than 255 characters */ a = 0X0000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000003FFA; printf ("Failed Deviance Test 2.7.1.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.1.2.CC b/Tests/Deviance/D2.7.1.2.CC new file mode 100755 index 0000000..cbd33a7 --- /dev/null +++ b/Tests/Deviance/D2.7.1.2.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.1.2: Ensure long integer constant overflows are */ /* caught as errors */ main () { long a; a = 2147483648; a = -2147483648L; a = 0xFFFFFFFF2; a = 0x800000001; a = 047777777777L; /* octal number with more than 255 characters */ a = 000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000003; /* hex number with more than 255 characters */ a = 0x0000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 0000000000000000000000000000000000000000000000000000000000000000000\ 00000000000000000000000000000000000000000000000000000000000003FF0110; printf ("Failed Deviance Test 2.7.1.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.2.1.CC b/Tests/Deviance/D2.7.2.1.CC new file mode 100755 index 0000000..2754f9b --- /dev/null +++ b/Tests/Deviance/D2.7.2.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.2.1: Ensure misformed floating-point constants are */ /* flagged as errors */ main () { float a; double b; a = .e+5; /* no digits before exponent */ b = .e-100; a = 0x7FE80; /* hex constant instead of digits */ b = 0x33.71; a = 0777E5; /* octal constant instead of digits */ b = 0043.71; a = 87t4.; /* invalid character in digit string */ b = 2@e-9; a = 39e*7; /* invalid sign character in exponent */ d = 54E/6; a = 98.E 8; /* space embedded within token */ b = 75.4 e+43; a = ..45; /* multiple decimal points */ b = 123.6.89; printf ("Failed Deviance Test 2.7.2.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.3.1.CC b/Tests/Deviance/D2.7.3.1.CC new file mode 100755 index 0000000..d70d419 --- /dev/null +++ b/Tests/Deviance/D2.7.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.3.1: Ensure unterminated character constants are */ /* flagged as errors */ main () { char a; int j; a = 'a; j = 5 * 76; a = '\t; a = '\006; printf ("Failed Deviance Test 2.7.3.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.3.2.CC b/Tests/Deviance/D2.7.3.2.CC new file mode 100755 index 0000000..33842c5 --- /dev/null +++ b/Tests/Deviance/D2.7.3.2.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.3.2: Ensure character constants contain only 1 charactr */ /* PAGE 20: DRAFT ANSI C PERMITS MULTIPLE CHAR CONSTANTS -- VALUE IS */ /* IMPLEMENTATION DEFINED */ main () { char a; a = 'ab'; a = '\t\n'; a = '\006HELP'; printf ("Failed Deviance Test 2.7.3.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.3.3.CC b/Tests/Deviance/D2.7.3.3.CC new file mode 100755 index 0000000..593587a --- /dev/null +++ b/Tests/Deviance/D2.7.3.3.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.3.3: Ensure character constants containing no */ /* characters are flagged as errors */ main () { char a, b; a = ''; b = ''; printf ("Failed Deviance Test 2.7.3.3\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.4.1.CC b/Tests/Deviance/D2.7.4.1.CC new file mode 100755 index 0000000..d706f88 --- /dev/null +++ b/Tests/Deviance/D2.7.4.1.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.4.1: Ensure string constants with no closing " are */ /* flagged as errors */ main () { char string [] = "badly formed string ; strcpy (string, "another bad string ); printf ("Failed Deviance Test 2.7.4.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D2.7.4.4.CC b/Tests/Deviance/D2.7.4.4.CC new file mode 100755 index 0000000..4c512aa --- /dev/null +++ b/Tests/Deviance/D2.7.4.4.CC @@ -0,0 +1 @@ +/* Deviance Test 2.7.3.5: Ensure functions cannot contain character string */ /* constants whose total length exceeds 8000 bytes */ main () { char s1 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; char s2 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; char s3 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ 0123456789"; printf ("Failed Deviance Test 2.7.3.5\n"); } int Dummy () { char s1 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; char s2 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ abcdefghijklmnopqrstuvwxyz01234567890123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; char s3 [] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ\ 0123456789"; return; } \ No newline at end of file diff --git a/Tests/Deviance/D25.0.1.CC b/Tests/Deviance/D25.0.1.CC new file mode 100755 index 0000000..248ffb4 --- /dev/null +++ b/Tests/Deviance/D25.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 25.0.1: Ensure illegal use mini-assembler is detected */ #include main () { int i, j; asm { 9__A: nop ; invalid label clcNoSuchOpcode ; illegal op code lda i * j - (j || i) ; invalid expression dupLab: dcl 0x888 ; duplicate labels dupLab: dcb 9 + 2 } printf ("Failed Deviance Test 25.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D25.0.2.CC b/Tests/Deviance/D25.0.2.CC new file mode 100755 index 0000000..3710021 --- /dev/null +++ b/Tests/Deviance/D25.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 25.0.2: Ensure branching to label + expression is detected */ #include main () { asm { bra Lbl1 + 0x8 Lbl1: nop } printf ("Failed Deviance Test 25.0.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.3.1.1.CC b/Tests/Deviance/D3.3.1.1.CC new file mode 100755 index 0000000..8062f01 --- /dev/null +++ b/Tests/Deviance/D3.3.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.3.1.1: Ensure invalid simple macro definitions are */ /* flagged as errors */ #DEfine BadDef 10 #DEFINE anotherBaddef 20 #define 7*8 name goes first! #define /* oops -- no name A-tall!!! */ main () { printf ("Failed Deviance Test 3.3.1.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.3.10.1.CC b/Tests/Deviance/D3.3.10.1.CC new file mode 100755 index 0000000..4322a2d --- /dev/null +++ b/Tests/Deviance/D3.3.10.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.3.10.1: Ensure macro bodies contain only complete tokens */ #define BadExp1 $ #define BadExp2 @~ #define BadChar1 'a #define BadChar2 z' #define BadString1 "not a complete string #define BadString2 nor is this" main () { printf ("Failed Deviance Test 3.3.10.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.3.2.1.CC b/Tests/Deviance/D3.3.2.1.CC new file mode 100755 index 0000000..ea059e2 --- /dev/null +++ b/Tests/Deviance/D3.3.2.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.3.2.1: Ensure invalid macro definitions/invocations */ /* are flagged as errors */ #define sameName1(name1,name1) name1 * name1 #define missingRParen(x,y x / y #define sameName1(a,b) a | b #define argsSeparatedWithSpaces(e f) e - f #define badArgs(&y,->t) &y & ->t #define sameName2 88 - 9 #define oneGoodOne(z1,z2) z1 * z2 #define sameName2 " same name 2 " main () { int a, b, c; /* Invoke macro with too few parameters. */ a = 3; c = oneGoodOne (a); /* Invoke macro with too many parameters. */ a = oneGoodOne (a, b, c); printf ("Failed Deviance Test 3.3.2.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.3.3.1.CC b/Tests/Deviance/D3.3.3.1.CC new file mode 100755 index 0000000..4239f6c --- /dev/null +++ b/Tests/Deviance/D3.3.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.3.3.1: Ensure macros which expand into preprocessor */ /* commands are not parsed as preprocessor cmds */ #define includeFile #include #define badValue #define reallyBadValue 5 main () { includeFile badValue printf ("Failed Deviance Test 3.3.3.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.3.4.1.CC b/Tests/Deviance/D3.3.4.1.CC new file mode 100755 index 0000000..65a72eb --- /dev/null +++ b/Tests/Deviance/D3.3.4.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.3.4.1: Ensure cannot redefine or undefine ORCA/C's */ /* predefined macros */ #define __LINE__ 5 #define __FILE__ "d3.3.4.1.cc" #define __DATE__ "Mar 01 1989" #define __TIME__ "10:10:10" #define __STDC__ illegal redefinition of __STDC__ #undef __LINE__ #undef __FILE__ #undef __DATE__ #undef __TIME__ #undef __STDC__ main () { printf ("Failed Deviance Test 3.3.4.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.3.5.1.CC b/Tests/Deviance/D3.3.5.1.CC new file mode 100755 index 0000000..b5b641d --- /dev/null +++ b/Tests/Deviance/D3.3.5.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.3.5.1: Check error generation for #undef commands */ #undef Name #define Name "hey" /* macro replacement is NOT done */ /* for #undef commands */ #define A "5" #define A "you" #undef A /* check "stack model" of redefining*/ /* macros -- not ANSI C */ #define cantUseIt 10 #undef cantUseIt main () { char a[] = A; int i; i = cantUseIt; printf ("Failed Deviance Test 3.3.5.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.4.0.1.CC b/Tests/Deviance/D3.4.0.1.CC new file mode 100755 index 0000000..bf9d597 --- /dev/null +++ b/Tests/Deviance/D3.4.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.4.0.1: Ensure errors flagged for invalid #include commands */ #define BadMacro(x) #include #include "nosuchfile" main () { printf ("Failed Deviance Test 3.4.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.5.1.1.CC b/Tests/Deviance/D3.5.1.1.CC new file mode 100755 index 0000000..5fec567 --- /dev/null +++ b/Tests/Deviance/D3.5.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.5.1.1: Check invalid #if, #else commands */ #if /* #if with no operand */ #else #endif #if a * b #define bad "this doesn't evaluate to a constant value" #else #endif #define macro1 1 #if 4 /* ensure improper nesting is detected */ #ifdef macro1 /* in "discarded" lines */ #ifndef noName #define TEN 10 #elif 5 #if defined(SIX) #ifdef EIGHTYONE #endif /* ifndef noName */ #endif /* ifdef macro1 */ #endif /* if 4 */ #if 1 /* ...as well as in non-discarded lines */ #ifdef macro1 #define SIXTEEN 16 #endif /* missing endif */ main () { printf ("Failed Deviance Test 3.5.1.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.5.2.1.CC b/Tests/Deviance/D3.5.2.1.CC new file mode 100755 index 0000000..c0b8e89 --- /dev/null +++ b/Tests/Deviance/D3.5.2.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.5.2.1: Ensure illegal #elif commands are flagged as errors */ #if 0 #define WHO_CARES 0 #elif 0 #if 1 #define WHO_REALLY_CARES 1 #elif 2 #define ARE_YOU_KIDDING 2 #elif 3 #define WHATS_FOR_LUNCH 3 #else #define LETS_LEAVE_OFF "endif" #elif 1 #define CATS_R_US 'c' #if CATS_R_US #define DOGS_R_US 'd' #endif #else #define LETS_NOT_LEAVE_OFF "endif" #endif #if 0 #elif /* no expression */ #endif main () { printf ("Failed Deviance Test 3.5.2.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.5.3.1.CC b/Tests/Deviance/D3.5.3.1.CC new file mode 100755 index 0000000..3fe0831 --- /dev/null +++ b/Tests/Deviance/D3.5.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.5.3.1: Ensure only macro names can be checked with the */ /* #ifdef and #ifndef commands */ main () { #ifdef a * 2 #endif #ifndef intPtr << 8 #endif #ifdef 76.5 - 8 #endif #ifndef #endif printf ("Failed Deviance Test 3.5.3.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3.5.5.1.CC b/Tests/Deviance/D3.5.5.1.CC new file mode 100755 index 0000000..8df166e --- /dev/null +++ b/Tests/Deviance/D3.5.5.1.CC @@ -0,0 +1 @@ +/* Deviance Test 3.5.5.1: Ensure invalid defined expressions are caught */ #define NAME "hey, you!" main () { if (defined NAME) /* defined can only appear in #if or #elif */ ; while (! (defined (NONAME)) ) ; do while (defined (NAME)); for (;defined (NAME);;) ; switch (defined (NAME)) ; #if defined /* missing name operand */ #elif defined #endif printf ("Failed Deviance Test 3.5.5.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D3401.DATA b/Tests/Deviance/D3401.DATA new file mode 100755 index 0000000..a2b0246 --- /dev/null +++ b/Tests/Deviance/D3401.DATA @@ -0,0 +1 @@ +#define one 1 #define two 2 #undef one #undef two \ No newline at end of file diff --git a/Tests/Deviance/D4.2.1.1.CC b/Tests/Deviance/D4.2.1.1.CC new file mode 100755 index 0000000..04a251a --- /dev/null +++ b/Tests/Deviance/D4.2.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.2.1.1: Ensure invalid scoping of identifiers is detected */ main () { int i; struct ComplexNum c; struct ComplexNum { float real; float imag; }; struct ComplexNum d; union LongOrShort z; union LongOrShort { long longNum; int shortNum; }; union LongOrShort ls; enum flowers f; enum flowers { rose, iris, canation }; enum flowers g; intPtr k; /* types not defined yet */ typedef int *intPtr; d.noSuchField = 0.0; z.real = 5; g = dahlia; ls.noNumber = 10; goto Hell; /* no offense... */ ch = F1 (g, i); G1(); printf ("Failed Conformance Test 4.2.1.1\n"); } /****************************************************************************/ char F1 (int x, int y); { intPtr k; struct ComplexNum c, *d; union LongOrShort z; enum flowers f; i = 5; G1(); return (3); } /******************************************************************************/ void G1 (void); { x += y; return; } \ No newline at end of file diff --git a/Tests/Deviance/D4.2.2.1.CC b/Tests/Deviance/D4.2.2.1.CC new file mode 100755 index 0000000..95d71ef --- /dev/null +++ b/Tests/Deviance/D4.2.2.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.2.2.1: Ensure "hiding" identifiers with same scope is */ /* detected */ #define MAC1 1 /* macro name */ #define MAC1 8 typedef int *intPtr; /* user-defined type */ typedef float *intPtr; int a; /* variables */ double a; struct aRecord { int a; }; /* type tag names */ union aRecord { long one; int two; }; enum aRecord { rec1, rec2, rec3 }; struct repeats { int r1; /* component names */ char ch; float r1; }; union moreRepeats { float x; int y; double y; }; enum stillOthers { red, black, green, green }; double D2 (int x, int z); /* function names */ int D2 (char k); main () { #define MAC2 2 /* macro name */ #define MAC2 3 typedef char *chPtr; /* user-defined type */ typedef short *chPtr; int cantRedeclare; /* variables */ double cantRedeclare; struct shortRec { int a; }; /* type tag names */ union shortRec { long one; int two; }; enum shortRec { rec1, rec2, rec3 }; struct repeats { int r1; /* component names */ char ch; float r1; }; union moreRepeats { float x; int y; double y; }; enum stillOthers { red, black, green, green }; double f1 ( ); /* function names */ char f1 (char k); printf ("Failed Deviance Test 4.2.2.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.2.3.1.CC b/Tests/Deviance/D4.2.3.1.CC new file mode 100755 index 0000000..4e594af --- /dev/null +++ b/Tests/Deviance/D4.2.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.2.3.1: Ensure illegal forward references are detected */ main () { int i; aPtr x; /* forward reference to user-defined type */ struct complex y; /* forward reference to type tag */ struct complex { float real; float imag; }; i = F1 ('a'); /* forward reference to prototyped function */ j = 3 * 7; /* forward reference to variable */ v.one = 1; /* forward reference to component */ } /*****************************************************************************/ int F1 (char ch) { return (int) ch; } \ No newline at end of file diff --git a/Tests/Deviance/D4.2.5.1.CC b/Tests/Deviance/D4.2.5.1.CC new file mode 100755 index 0000000..a079fb5 --- /dev/null +++ b/Tests/Deviance/D4.2.5.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.2.5.1: Ensure duplicate declarations of the same */ /* identifiers in the same overloading class and */ /* sharing the same scope are detected */ /* Errors at top level */ #define macro1 "hey" /* preprocessor macro names */ #define macro1 8 struct s1 { int a; /* type tags */ int b; }; union s1 { int x; float y; }; enum s1 { a, b, c}; struct s2 { int r; /* component names */ char ch; float r; }; union u1 { int x; long x; }; double a [5]; /* all other names: variables, */ float *a; /* functions, typedef names, */ extern int F1 (void); /* enumeration constants */ int F1; typedef float real; float real; enum flowers { rose, iris, daisy, thistle }; int rose; int i; typedef int i; typedef double d1; typedef int d1; float F2 (int m); typedef int *F2; typedef float iris; double p; extern double p (void); extern void Daisy (void); typedef double doublePrec; extern float doublePrec (void); int L [10]; float one (int abc); typedef int *two; enum numbers { L, one, two }; /* Errors within a function */ main () { #define macro99 99 /* preprocessor macro names */ #define macro99 999 struct ll { char z; /* type tags */ int m; }; union ll { int x; float y; }; enum ll { lll, llll, lllll }; struct jy { float f0; /* component names */ char ch; float f0; }; union u1 { int x [3]; long x; }; double b [5]; /* all other names: variables, */ float *b; /* functions, typedef names, */ int Moth (int m0); /* enumeration constants */ int Moth; typedef extended ext; double ext; enum people { Joe, Mike, Patty, Jim }; char Jim; float floatOne; typedef float floatOne; typedef int *repeatIt; typedef int *repeatIt; extended Ext2 (extended ext2); typedef int *Ext2; typedef void Joe; long aLongNum; extern long aLongNum (long longLong); extern void Mike (int Patty); typedef unsigned UnSigned; extern int UnSigned (void); extended array [98]; double Func1 (double doubleDouble); typedef long *Long; enum objects { array, Long, Func1 }; printf ("Failed Deviance Test 4.2.5.1\n"); } /* Two functions with same name */ /****************************************************************************/ int Xx (void) { } /****************************************************************************/ double Xx (char a) { } \ No newline at end of file diff --git a/Tests/Deviance/D4.2.9.1.CC b/Tests/Deviance/D4.2.9.1.CC new file mode 100755 index 0000000..bc5f1e7 --- /dev/null +++ b/Tests/Deviance/D4.2.9.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.2.9.1: Ensure illegal scoping of extern variables is */ /* detected */ double X; main () { int i; if (i - 1) /* variable E should not be visible */ { /* in the else clause */ extern extended E; E = 5.7; } else { E = 1.0; } printf ("Failed Deviance Test 4.2.9.1\n"); } /*****************************************************************************/ double F1 (int x, int y) { int x; /* both declarations are in error -- */ float y; /* cannot redefine function parms */ } \ No newline at end of file diff --git a/Tests/Deviance/D4.3.0.1.CC b/Tests/Deviance/D4.3.0.1.CC new file mode 100755 index 0000000..8c9f4dd --- /dev/null +++ b/Tests/Deviance/D4.3.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.3.0.1: Ensure illegal storage class specifications are */ /* detected */ typedef double DblFunc (void); static int ReturnInt (long l); /* ReturnInt should be defined later in file */ auto int s; /* auto can only be used in head of block */ register short f; /* register can only be used with local */ /* variables and function parameters */ main () { int i; extern auto float y; /* only 1 storage class per declaration */ auto int register a; static typedef int *l; i = ReturnInt (55); /* call static function declared but not defined */ printf ("Failed Deviance Test 4.3.0.1\n"); } /****************************************************************************/ auto double F1 (int a) /* functions can only be extern or static */ { } /****************************************************************************/ register int Int (void) /* functions can only be extern or static */ { } /****************************************************************************/ DblFunc FF (void) /* cannot inherit type of function definition */ { /* from a typedef name */ } /****************************************************************************/ /* Function parameters can only have storage class register */ static long Long (auto int i, extern float f, static long m, typedef int ptr) { } \ No newline at end of file diff --git a/Tests/Deviance/D4.4.1.1.CC b/Tests/Deviance/D4.4.1.1.CC new file mode 100755 index 0000000..710d91f --- /dev/null +++ b/Tests/Deviance/D4.4.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.4.1.1: Ensure declarations contain either a type specifier */ /* or storage class specifier or both */ main () { j; printf ("Failed Deviance Test 4.4.1.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.5.3.1.CC b/Tests/Deviance/D4.5.3.1.CC new file mode 100755 index 0000000..cd8a981 --- /dev/null +++ b/Tests/Deviance/D4.5.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.5.3.0.1: Ensure illegal array dimensions are detected */ static int x [0]; /* zero not allowed for dimension */ static float y [0] [5] [9]; static double k [3] [6] [2] [0]; static extended L [-3] [7]; /* negative dimension not allowed */ static long M [8] [2] []; /* must specify LAST n-1 dimensions */ /*****************************************************************************/ int F1 (float n [3] []) { return 0; } /*****************************************************************************/ long L1 (char ch1 [] []) { return 0; } /*****************************************************************************/ main () { char ch0 [0], ch2 [9] [0], ch3 [8] [7] [0] [6]; extended ext [2] [0] [9] [0]; int i [3] [] = { 1, 2 }; /* must specify LAST n-1 dimensions */ int k; float n [5] [3]; k = F1 (n [5] []); k = F1 (n); printf ("Failed Deviance Test 4.5.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.0.1.CC b/Tests/Deviance/D4.6.0.1.CC new file mode 100755 index 0000000..7d7cdef --- /dev/null +++ b/Tests/Deviance/D4.6.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.0.1: Ensure attempt to initialize variables of type */ /* void and function is detected */ static void v1 = 5; void v2 = 88; static int F1 (char ch) = 5; float F2 (double d3) = 5.6; main () { printf ("Failed Deviance Test 4.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.0.2.CC b/Tests/Deviance/D4.6.0.2.CC new file mode 100755 index 0000000..82efd8a --- /dev/null +++ b/Tests/Deviance/D4.6.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.0.2: Ensure attempt to initialize variables of type */ /* void and function is detected */ main () { void v3 = 99.0; register void v4 = 'a'; static char F3 (void) = 'm'; extended F4 (int x, int y) = 4.0E300; printf ("Failed Deviance Test 4.6.0.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.1.1.CC b/Tests/Deviance/D4.6.1.1.CC new file mode 100755 index 0000000..bb9a07b --- /dev/null +++ b/Tests/Deviance/D4.6.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.1.1: Ensure non-constant initialization of static and */ /* extern variables is detected */ static int i = 5; static int j = i + 2; static long L1 = &i - j; static char ch1 = (char) L1 / i; static unsigned int u1 = 5 >> ch1; static unsigned long ul1 = (unsigned long) (u1); int ext1 = r7 * 7; long ext2 = (int) 98.7 - i; char ext3 = ch1 / ch1; unsigned int ext4 = ext3 || ext1; unsigned long ext5 = ul1; main () { static int m1 = m1 - 0; static long m2 = ch1; static char m3 = 'a' + 'b' - ext3; static unsigned int m4 = m2 + ul1; static unsigned long m5 = ext5; printf ("Failed Deviance Test 4.6.1.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.2.1.CC b/Tests/Deviance/D4.6.2.1.CC new file mode 100755 index 0000000..4afaa68 --- /dev/null +++ b/Tests/Deviance/D4.6.2.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.2.1: Ensure non-constant floating-point initializers */ /* for static and extern variables is detected */ static float f0 = 1.0; static float f1 = f0 * 2.0; static double d1 = f0 + f1; static extended e1 = f0 / 4.6; float f2 = (float) e1; double d2 = f0--; extended e2 = f0 - f1; main () { float f00 = 5.6 * f0; static float f3 = f00; static double d3 = 3.5 / f3; static extended e3 = f00; extern float f4 = 8.1; /* extern + initializers are not allowed */ extern double d4 = f0; extern extended e4 = (extended) 5.0; printf ("Failed Deviance Test 4.6.2.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.3.1.CC b/Tests/Deviance/D4.6.3.1.CC new file mode 100755 index 0000000..51811f3 --- /dev/null +++ b/Tests/Deviance/D4.6.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.3.1: Ensure illegal pointer initializations are detected */ main () { int i2 [5], i1 = 5; static int i1Ptr = i2; /* can't take address of local array */ extern int i2Ptr = &i2 [3]; register float f1 [10]; /* no such thing as register arrays */ float *fptr = (float) (i1 - 1.0); /* expression is not integral constant */ printf ("Failed Deviance Test 4.6.3.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.4.1.CC b/Tests/Deviance/D4.6.4.1.CC new file mode 100755 index 0000000..ec4c367 --- /dev/null +++ b/Tests/Deviance/D4.6.4.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.4.1: Ensure illegal array initializations are detected */ static int i1 [3] = { 1, 2, 3, 4 }; /* too many elements */ static long L1 [4] = { 1, 2, 3, 4, 5, 5, 7 }; static double d1 [3] = { 1.0, 2.0, 3.0, 4.0 }; static struct S1 { int i; float f; } s1 [2] = { {2, 1.0}, {3, 2.0}, {4, 3.0}, {5, 4.0} }; char ch1 [2] = "oh, what a beautiful baby!!"; comp c1 [3] = { 1, 2, 3, 4, 5, 6 }; float f1 [1] = { 0, 0, 0, 0, 0, 0 }; int i2 = 3; float f2 = 3.0; /* non-constant values */ static short i3 [] = { i2 * 2, i2 / 2 }; static double d3 [3] = { 3.0, (double) f2 }; static struct S1 s2 [2] = { i3 [0], f2 }; unsigned int i4 [2] = { i3 [1], i2 }; unsigned long L2 [4] = { (unsigned long) f2 + 3 }; main () { int i5 [7] = { 14, 15, 16, 17, 18, 19, 20, 21 }; /* too many elements */ float f5 [3] = { 1.1, 1.1, 1.1, 1.1, 4.4 }; char ch [5] = "abcde"; /* no room for ending */ /* null */ double d5 [3] = { (double) (i2 * 2.3) }; /* non-constant values */ struct S1 s5 [2] = { i2 - (i2 + 2), f2 / 7.2 }; printf ("Failed Deviance Test 4.6.4.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.5.1.CC b/Tests/Deviance/D4.6.5.1.CC new file mode 100755 index 0000000..0cce76f --- /dev/null +++ b/Tests/Deviance/D4.6.5.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.5.1: Ensure illegal enumeration initializations are */ /* detected */ static struct S { int i; float f; } s = { 2, 4.5 }; static char ch [] = "hey!"; static enum E1 { a, b, c } e1 = s; enum E2 { d, e, f } e2 = &ch; main () { enum E3 { g, h } e3 = &s; register enum E4 { i, j, k } e4 = ch; printf ("Failed Deviance Test 4.6.5.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.6.1.CC b/Tests/Deviance/D4.6.6.1.CC new file mode 100755 index 0000000..26b01e1 --- /dev/null +++ b/Tests/Deviance/D4.6.6.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.6.1: Ensure illegal initialization of structures is */ /* detected */ struct S1 { int i; float f; } s1 = { 3, 8.0, 'a' }; /* too many values */ struct S1 s2 = 2, 7.6; /* can't omit outer braces */ static struct S1 s3 = { 5, 5.0, 6.0, 77.77 }; /* too many values */ static struct S1 s4 = 0, 0.0; /* can't omit outer braces */ main () { int i = 8; float f = 3.5; auto struct S1 s1 = { i * 2, f }; /* can only use constants */ register struct S1 s2 = { s1.i, f / 3.0 }; auto struct S1 s3 = { 4, 4, 5, }; /* too many values */ register struct S1 s4 = { 3, 2.0, 5.0E10 }; auto struct S1 s5 = 6, 17.9; /* can't omit outer braces */ register struct S1 s6 = 77, 90.0; printf ("Failed Deviance Test 4.6.6.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.7.1.CC b/Tests/Deviance/D4.6.7.1.CC new file mode 100755 index 0000000..3c1cf3d --- /dev/null +++ b/Tests/Deviance/D4.6.7.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.7.1: Ensure illegal initialization of unions is detected */ union U1 { int i; long L; char ch [5]; }; union U1 u1 = "hey, you!"; /* init. must be valid for only 1st type */ static union U1 u2 = &u1.i; union U1 u3 = { 5, 6, "a", 2, 3 }; /* too many values */ static union U1 u4 = { 2, 4, 6.0 }; main () { int i = 5; auto union U1 u5 = { "abb" }; /* init. must be valid for only 1st type */ static union U1 u6 = { &i }; union U1 u7 = { 5, 7, 8.8 }; /* too many values */ printf ("Failed Deviance Test 4.6.7.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D4.6.8.1.CC b/Tests/Deviance/D4.6.8.1.CC new file mode 100755 index 0000000..34e2a6d --- /dev/null +++ b/Tests/Deviance/D4.6.8.1.CC @@ -0,0 +1 @@ +/* Deviance Test 4.6.8.1: Ensure improper dropping of initializer braces */ /* is detected */ static int i1 [3] = 1, 2, 3; /* can't drop outer braces for arrays */ float f1 [2] = 3.1, 2.3; /* and structures */ struct S1 { char ch; float f; }; static struct S1 s1 = 'a', 3.3; struct S1 s2 = 'b', 4.4; struct S2 { comp c1 [3]; long L1 [2]; char ch; }; main () { unsigned int ui1 [4] = 2, 3; /* can't drop outer braces for arrays */ struct S1 s3 = 'a', 3.3; /* and structures */ printf ("Failed Deviance Test 4.6.8.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D7.1.1.1.CC b/Tests/Deviance/D7.1.1.1.CC new file mode 100755 index 0000000..9ddb6d7 --- /dev/null +++ b/Tests/Deviance/D7.1.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.1.1.1: Ensure illegal use of non-lvalues is detected */ main () { int i [10]; /* names of arrays, functions, enum */ enum E {a, b, c}; /* constants, & void variables */ void v; /* are not lvalues */ static float F (void); float (*fptr) (); i = 5; /* cannot apply &, ++, --, or assign */ a++; /* operators to non-lvalues */ v = F (); fptr = &(F--); --i; ++b; --c; printf ("Failed Deviance Test 7.1.1.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D7.5.4.1.CC b/Tests/Deviance/D7.5.4.1.CC new file mode 100755 index 0000000..bda9909 --- /dev/null +++ b/Tests/Deviance/D7.5.4.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.5.4.1: Ensure illegal use of bitwise negation is detected */ #include main () { float f = 1.1; /* can only apply ~ operator to integers */ double d = 2.2; extended e = 3.3; static float F (void); f = ~f; d = ~d; e = ~e; F = ~F (); printf ("Failed Deviance Test 7.5.4.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.1.1.CC b/Tests/Deviance/D7.6.1.1.CC new file mode 100755 index 0000000..0638e47 --- /dev/null +++ b/Tests/Deviance/D7.6.1.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.1.1: Ensure illegal use of remainder op is detected */ #include main () { float f = 1.1; /* can only apply % operator to integers */ double d = 2.2; extended e = 3.3; static float F (void); f = f % 1.0; d = d % 5; e = e % e; f = 88 % F (); printf ("Failed Deviance Test 7.6.1.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.1.2.CC b/Tests/Deviance/D7.6.1.2.CC new file mode 100755 index 0000000..4541e31 --- /dev/null +++ b/Tests/Deviance/D7.6.1.2.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.1.2: Check for illegal / in a constant expression */ #include void main(void) { int i; i = 4/0; printf("Failed Deviance Test 7.6.1.2\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.1.3.CC b/Tests/Deviance/D7.6.1.3.CC new file mode 100755 index 0000000..8c80ffb --- /dev/null +++ b/Tests/Deviance/D7.6.1.3.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.1.3: Check for illegal % in a constant expression */ #include void main(void) { int i; i = 4%(-1); printf("Failed Deviance Test 7.6.1.3\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.1.4.CC b/Tests/Deviance/D7.6.1.4.CC new file mode 100755 index 0000000..a5770c7 --- /dev/null +++ b/Tests/Deviance/D7.6.1.4.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.1.4: Check for illegal float / in a constant expression */ #include void main(void) { float f; f = 4.0 / 0.0; printf("Failed Deviance Test 7.6.1.4\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.3.1.CC b/Tests/Deviance/D7.6.3.1.CC new file mode 100755 index 0000000..304d906 --- /dev/null +++ b/Tests/Deviance/D7.6.3.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.3.1: Ensure illegal use of shift operators is detected */ #include main () { float f = 1.1; /* can only apply >>, << operators to integers */ double d = 2.2; extended e = 3.3; static float F (void); f = f >> 1.0; d = d >> 5; e = e >> e; f = 88 >> F (); f = f << 1.0; d = d << 5; e = e << e; f = 88 << F (); printf ("Failed Deviance Test 7.6.3.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.4.1.CC b/Tests/Deviance/D7.6.4.1.CC new file mode 100755 index 0000000..0e60682 --- /dev/null +++ b/Tests/Deviance/D7.6.4.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.4.1: Ensure illegal use of relational operators is */ /* detected */ #include main () { float f = 1.1, *fptr = &f; /* can only compare pointers with pointers */ char ch = 'a', *chptr = &ch; int i; i = (fptr <= 0xabcd); i = (i < fptr); i = chptr >= ch; i = 'Z' > chptr; i = fptr < 5.5; printf ("Failed Deviance Test 7.6.4.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.6.1.CC b/Tests/Deviance/D7.6.6.1.CC new file mode 100755 index 0000000..19d9115 --- /dev/null +++ b/Tests/Deviance/D7.6.6.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.6.1: Ensure illegal use of bitwise AND is detected */ #include main () { float f = 1.1; /* can only apply & operator to integers */ double d = 2.2; extended e = 3.3; static float F (void); f = f & 1.0; d = d & 5; e = e & e; f = 88 & F (); printf ("Failed Deviance Test 7.6.6.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.7.1.CC b/Tests/Deviance/D7.6.7.1.CC new file mode 100755 index 0000000..d3e43f8 --- /dev/null +++ b/Tests/Deviance/D7.6.7.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.7.1: Ensure illegal use of bitwise XOR is detected */ #include main () { float f = 1.1; /* can only apply ^ operator to integers */ double d = 2.2; extended e = 3.3; static float F (void); f = f ^ 1.0; d = d ^ 5; e = e ^ e; f = 88 ^ F (); printf ("Failed Deviance Test 7.6.7.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D7.6.8.1.CC b/Tests/Deviance/D7.6.8.1.CC new file mode 100755 index 0000000..bd19c4a --- /dev/null +++ b/Tests/Deviance/D7.6.8.1.CC @@ -0,0 +1 @@ +/* Deviance Test 7.6.8.1: Ensure illegal use of bitwise OR is detected */ #include main () { float f = 1.1; /* can only apply | operator to integers */ double d = 2.2; extended e = 3.3; static float F (void); f = f | 1.0; d = d | 5; e = e | e; f = 88 | F (); printf ("Failed Deviance Test 7.6.8.1\n"); } static float F (void) { return 1.0; } \ No newline at end of file diff --git a/Tests/Deviance/D8.7.0.1.CC b/Tests/Deviance/D8.7.0.1.CC new file mode 100755 index 0000000..02941bf --- /dev/null +++ b/Tests/Deviance/D8.7.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 8.7.0.1: Ensure illegal switch statements are detected */ #include main () { int i = 3, j = 4; unsigned short s = 7; switch 3 /* omit switch expr's () */ default: ; switch (i) /* non-constant case expressions */ { case i * j: break; case j: break; } switch (j) /* omit case expression */ case: break; switch (i) /* non-unique case expressions */ { case 3: break; case 4: break; default: break; case 3: break; } switch (s) /* case expression of different */ { /* type than switch expression */ case -3: break; case -88: break; } switch (i) /* only 1 default label allowed */ { case 1: break; default: break; case 2: default: break; } case 22: i = 3; /* case label only allowed in switch body */ default: j = 90; /* default label only allowed in switch */ switch (76.443); /* switch expr can't be floating point typ*/ switch (&j + 1); /* switch expr can't be pointer type */ printf ("Failed Deviance Test 8.7.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D8.8.0.1.CC b/Tests/Deviance/D8.8.0.1.CC new file mode 100755 index 0000000..0783b19 --- /dev/null +++ b/Tests/Deviance/D8.8.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 8.8.0.1: Ensure illegal break and continue statements are */ /* detected */ #include main () { break; /* break outside of while, do, for, switch statement */ continue; /* continue outside of while, do, for statement */ switch (1) { case 1: continue; } printf ("Failed Deviance Test 8.8.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/D9.2.0.1.CC b/Tests/Deviance/D9.2.0.1.CC new file mode 100755 index 0000000..ab14685 --- /dev/null +++ b/Tests/Deviance/D9.2.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 9.2.0.1: Ensure attempt to return an array or function */ /* from a function is detected */ #include /*****************************************************************************/ int ( g (float f) ) [] /* g is a func returning an array of integers */ { printf ("This message should never appear\n"); } /*****************************************************************************/ void ( f (void) ) () /* f is a func returning a func returning void */ { printf ("This message should never appear\n"); } /*****************************************************************************/ main () { printf ("Failed Deviance Test 9.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Deviance/DOIT b/Tests/Deviance/DOIT new file mode 100755 index 0000000..b4e5ca5 --- /dev/null +++ b/Tests/Deviance/DOIT @@ -0,0 +1 @@ +{1} D2.1.0.1.CC {1} D2.2.0.2.CC {1} D2.4.0.1.CC {1} D2.5.0.1.CC {1} D2.5.0.2.CC {1} D2.7.1.1.CC {1} D2.7.1.2.CC {1} D2.7.2.1.CC {1} D2.7.3.1.CC {1} D2.7.3.2.CC {1} D2.7.3.3.CC {1} D2.7.4.1.CC {1} D2.7.4.4.CC {1} D25.0.1.CC {1} D25.0.2.CC {1} D3.3.1.1.CC {1} D3.3.10.1.CC {1} D3.3.2.1.CC {1} D3.3.3.1.CC {1} D3.3.4.1.CC {1} D3.3.5.1.CC {1} D3.4.0.1.CC {1} D3.5.1.1.CC {1} D3.5.2.1.CC {1} D3.5.3.1.CC {1} D3.5.5.1.CC {1} D4.2.1.1.CC {1} D4.2.2.1.CC {1} D4.2.3.1.CC {1} D4.2.5.1.CC {1} D4.2.9.1.CC {1} D4.3.0.1.CC {1} D4.4.1.1.CC {1} D4.5.3.1.CC {1} D4.6.0.1.CC {1} D4.6.0.2.CC {1} D4.6.1.1.CC {1} D4.6.2.1.CC {1} D4.6.3.1.CC {1} D4.6.4.1.CC {1} D4.6.5.1.CC {1} D4.6.6.1.CC {1} D4.6.7.1.CC {1} D4.6.8.1.CC {1} D7.1.1.1.CC {1} D7.5.4.1.CC {1} D7.6.1.1.CC {1} D7.6.1.2.CC {1} D7.6.1.3.CC {1} D7.6.1.4.CC {1} D7.6.3.1.CC {1} D7.6.4.1.CC {1} D7.6.6.1.CC {1} D7.6.7.1.CC {1} D7.6.8.1.CC {1} D8.7.0.1.CC {1} D8.8.0.1.CC {1} D9.2.0.1.CC \ No newline at end of file diff --git a/Tests/Deviance/RUN.DEVIANCE b/Tests/Deviance/RUN.DEVIANCE new file mode 100755 index 0000000..c5a7500 --- /dev/null +++ b/Tests/Deviance/RUN.DEVIANCE @@ -0,0 +1 @@ +* * * EXEC file to run the deviance tests for the ORCA/C compiler. Script file * * simply ensures that compiler's error reporting doesn't crash. * * * * The EXEC file accepts one parameter, the name of the file to receive output * * from the test * * * unset exit if {#} != 0 set out ">> {1} >>& {1}" end * Run tests for Chapter 2, Harbison and Steele for i in 1.0.1 2.0.2 4.0.1 5.0.1 5.0.2 7.1.1 7.1.2 7.2.1 echo Test d2.{i}.cc if {#} != 0 echo Test d2.{i}.cc {out} end run d2.{i}.cc keep=3/tmp {out} end for i in 3.1 3.2 3.3 4.1 4.3 4.4 echo Test d2.7.{i}.cc if {#} != 0 echo Test d2.7.{i}.cc {out} end run d2.7.{i}.cc keep=3/tmp {out} end * Run tests for Chapter 3, Harbison and Steele for i in 3.1 3.2 3.3 3.4 3.5 3.10 4.0 5.1 5.2 echo Test d3.{i}.1.cc if {#} != 0 echo Test d3.{i}.1.cc {out} end run d3.{i}.1.cc keep=3/tmp {out} end for i in 3.1 5.1 echo Test d3.5.{i}.cc if {#} != 0 echo Test d3.5.{i}.cc {out} end run d3.5.{i}.cc keep=3/tmp {out} end * Run tests for Chapter 4, Harbison and Steele for i in 2.1 2.2 2.3 2.5 2.9 3.0 4.1 5.3 6.0 echo Test d4.{i}.1.cc if {#} != 0 echo Test d4.{i}.1.cc {out} end run d4.{i}.1.cc keep=3/tmp {out} end for i in 6.0.2 6.1.1 6.2.1 6.3.1 6.4.1 6.5.1 echo Test d4.{i}.cc if {#} != 0 echo Test d4.{i}.cc {out} end run d4.{i}.cc keep=3/tmp {out} end for i in 6 7 8 echo Test d4.6.{i}.1.cc if {#} != 0 echo Test d4.6.{i}.1.cc {out} end run d4.6.{i}.1.cc keep=3/tmp {out} end * Run tests for Chapter 7, Harbison and Steele for i in 1.1 5.4 6.1 6.3 6.4 6.6 6.7 6.8 echo Test d7.{i}.1.cc if {#} != 0 echo Test d7.{i}.1.cc {out} end run d7.{i}.1.cc keep=3/tmp {out} end for i in 2 3 4 echo Test d7.6.1.{i}.cc if {#} != 0 echo Test d7.6.1.{i}.cc {out} end run d7.6.1.{i}.cc keep=3/tmp {out} end * Run tests for Chapters 8, and 9, Harbison and Steele for i in 8.7 8.8 9.2 echo Test d{i}.0.1.cc if {#} != 0 echo Test d{i}.0.1.cc {out} end run d{i}.0.1.cc keep=3/tmp {out} end * Run tests for mini-assembler for i in 1 2 echo Test d25.0.{i}.cc if {#} != 0 echo Test d25.0.{i}.cc {out} end run d25.0.{i}.cc keep=3/tmp {out} end \ No newline at end of file diff --git a/Tests/Deviance/TEST b/Tests/Deviance/TEST new file mode 100755 index 0000000..aa32ccb --- /dev/null +++ b/Tests/Deviance/TEST @@ -0,0 +1 @@ +unset exit compile -e -i {1} keep=3/t >3/temp if {status} == 0 echo Failed {1} else echo Passed {1} end \ No newline at end of file diff --git a/Tests/Deviance/TEST2 b/Tests/Deviance/TEST2 new file mode 100755 index 0000000..f72eaee --- /dev/null +++ b/Tests/Deviance/TEST2 @@ -0,0 +1 @@ +unset exit compile -e -i {1} keep=3/t if {status} == 0 echo Failed {1} else echo Passed {1} end \ No newline at end of file diff --git a/Tests/Spec.Conform/CFILE1 b/Tests/Spec.Conform/CFILE1 new file mode 100755 index 0000000..086e2a1 --- /dev/null +++ b/Tests/Spec.Conform/CFILE1 @@ -0,0 +1 @@ +#define TEN 10 #define NINE 9 \ No newline at end of file diff --git a/Tests/Spec.Conform/LIBFILE2 b/Tests/Spec.Conform/LIBFILE2 new file mode 100755 index 0000000..b59af9b --- /dev/null +++ b/Tests/Spec.Conform/LIBFILE2 @@ -0,0 +1 @@ + printf ("Passed Special Conformance Test 3.4.0.1\n"); return 0; Fail: printf ("Failed Special Conformance Test 3.4.0.1\n"); return 0; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC13.2.0.1.CC b/Tests/Spec.Conform/SPC13.2.0.1.CC new file mode 100755 index 0000000..f598ad6 --- /dev/null +++ b/Tests/Spec.Conform/SPC13.2.0.1.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 13.2.0.1: Verification of error handling */ /* facilities in the standard library */ /* */ /* Tester needs to verify that an error message is written for each */ /* invocation of strerror and perror. She should also check that the */ /* output from perror is in this form: User's message, colon, blank, and */ /* then the standard error message. Finally, the tester needs to ensure */ /* that when errno is set to EDOM and ERANGE, the error message written */ /* is appropriate. */ /* */ #include #include #include #include #include main () { int i; char ch [] = "Error message is"; for (errno = 1; errno <= sys_nerr; errno++) { printf ("Errno = %d\n", errno); printf ("%s\n", strerror (errno)); perror (ch); } errno = EDOM; printf ("Errno = %d\n", errno); printf ("%s\n", strerror (errno)); perror (ch); errno = ERANGE; printf ("Errno = %d\n", errno); printf ("%s\n", strerror (errno)); perror (ch); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC13.4.0.1.CC b/Tests/Spec.Conform/SPC13.4.0.1.CC new file mode 100755 index 0000000..684e028 --- /dev/null +++ b/Tests/Spec.Conform/SPC13.4.0.1.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 13.4.0.1: Verification of stdarg library facility */ /* */ /* The tester needs to verify that the values 2, 'c', 1.3, 4.4, and 7.7 are */ /* printed to standard out. */ /* */ #pragma optimize -1 #include enum types { integer, character, singlePrecision, doublePrecision, extendedPrecision, endOfList }; main () { int i = 2; char ch = 'c'; float f = 1.3; double d = 4.4; extended e = 7.7; enum types typesArray [80]; void VariablePrint ( enum types *typesArray, ... ); typesArray [0] = integer; /* init. array of types of values */ typesArray [1] = character; /* to print */ typesArray [2] = singlePrecision; typesArray [3] = doublePrecision; typesArray [4] = extendedPrecision; typesArray [5] = endOfList; VariablePrint ( typesArray, i, ch, f, d, e ); /* call function which takes */ } /* variable number args */ /****************************************************************************/ void VariablePrint ( enum types *typesArray, ... ) { va_list ap; enum types nextType; va_start (ap, typesArray); /* initialize variable argument ptr */ while ( (nextType = *typesArray++) != endOfList ) { switch (nextType) { case integer: printf ("int: %d\n", va_arg (ap, int)); break; case character: printf ("char: %c\n", va_arg (ap, int)); break; case singlePrecision: case doublePrecision: case extendedPrecision: printf ("extended: %e\n", va_arg (ap, extended)); break; default: printf ("Error in VariablePrint"); break; } /* end switch */ } /* end while */ va_end (ap); /* clean up stack, etc. */ } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.16.0.1.CC b/Tests/Spec.Conform/SPC17.16.0.1.CC new file mode 100755 index 0000000..197f82c --- /dev/null +++ b/Tests/Spec.Conform/SPC17.16.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.16.0.1: Verification of tmpnam function */ /* */ /* The temporary filenames that the system generates will be displayed. */ /* The tester needs to verify that these files are created after the */ /* the test is complete. */ #include #include struct S { int i; float f; char c; }; main () { struct S s [3] = { 1, 1.0, 'a', 2, 2.0, 'b', 3, 3.0, 'c' }; struct S buff [3]; FILE *f1, *f2, *f3; int i; char filename [3] [L_tmpnam]; /* filename buffers */ char *namePtr; /* Call tmpnam to obtain 3 filenames and display the names to the tester. */ namePtr = tmpnam (filename [0]); if (namePtr == NULL) goto Fail; if (strcmp (namePtr,filename [0])) goto Fail; printf ("The first filename is: %s\n", filename [0]); namePtr = tmpnam (filename [1]); if (namePtr == NULL) goto Fail; if (strcmp (namePtr, filename [1])) goto Fail; printf ("The second filename is: %s\n", filename [1]); namePtr = tmpnam (NULL); /* test sending NULL pointer */ if (namePtr == NULL) goto Fail; printf ("The third filename is: %s\n", namePtr); namePtr = strcpy (filename [2], namePtr); if (strcmp (namePtr, filename [2])) goto Fail; /* Create 3 temp files and write the elements to the files. */ f1 = fopen (filename [0], "w+b"); if (f1 == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f1); if (i != 3) goto Fail; f2 = fopen (filename [1], "w+b"); if (f2 == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f2); if (i != 3) goto Fail; f3 = fopen (filename [2], "w+b"); if (f3 == NULL) goto Fail1; i = fwrite ((void *) s, sizeof (struct S), 3, f3); if (i != 3) goto Fail; /* Read the elements from the files. */ rewind (f1); i = fread ((void *) buff, sizeof (struct S), 3, f1); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((s [0].f != 1.0) || (s [1].f != 2.0) || (s [2].f != 3.0)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; rewind (f2); i = fread ((void *) buff, sizeof (struct S), 3, f2); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((s [0].f != 1.0) || (s [1].f != 2.0) || (s [2].f != 3.0)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; rewind (f2); i = fread ((void *) buff, sizeof (struct S), 3, f2); if (i != 3) goto Fail; if ((s [0].i != 1) || (s [1].i != 2) || (s [2].i != 3)) goto Fail; if ((s [0].f != 1.0) || (s [1].f != 2.0) || (s [2].f != 3.0)) goto Fail; if ((s [0].c != 'a') || (s [1].c != 'b') || (s [2].c != 'c')) goto Fail; i = fclose (f1); /* close the files and quit */ if (i == EOF) goto Fail2; i = fclose (f2); if (i == EOF) goto Fail2; i = fclose (f3); if (i == EOF) goto Fail2; printf ("Passed Special Conformance Test 17.16.0.1\n"); return; Fail: printf ("Failed Special Conformance Test 17.16.0.1\n"); exit (0); Fail1: printf ("Unable to open temp file for Special Conformance Test 17.16.0.1\n"); exit (0); Fail2: printf ("Unable to close output file for Special Conformance Test 17.16.0.1\n"); exit (0); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.2.0.1.CC b/Tests/Spec.Conform/SPC17.2.0.1.CC new file mode 100755 index 0000000..bcdc183 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.2.0.1.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 17.2.0.1: Verification of fopen and fclose: */ /* creating new files */ /* */ /* Tester needs to verify that the 12 files named spc17.2.0.a - spc17.2.0.l */ /* are created on the work prefix. */ /* */ #include main () { int i, count = 0; FILE *f1, *f2, *f3, *f4, *f5, *f6, *f7, *f8; /* must be able to open */ /* 8 files at a time */ char fn1 [14] = "3/spc17.2.0.a"; /* define filenames */ char fn2 [14] = "3/spc17.2.0.b"; char fn3 [14] = "3/spc17.2.0.c"; char fn4 [14] = "3/spc17.2.0.d"; char fn5 [14] = "3/spc17.2.0.e"; char fn6 [14] = "3/spc17.2.0.f"; char fn7 [14] = "3/spc17.2.0.g"; char fn8 [14] = "3/spc17.2.0.h"; char fn9 [14] = "3/spc17.2.0.i"; char fn10 [14] = "3/spc17.2.0.j"; char fn11 [14] = "3/spc17.2.0.k"; char fn12 [14] = "3/spc17.2.0.l"; count++; f1 = fopen (fn1, "w"); /* open for writing */ if (f1 == NULL) goto Fail; count++; f2 = fopen (fn2, "w"); if (f2 == NULL) goto Fail; count++; f3 = fopen (fn3, "a"); /* open for appending */ if (f3 == NULL) goto Fail; count++; f4 = fopen (fn4, "w+"); /* open for update, starting at */ if (f4 == NULL) /* beginning of file */ goto Fail; count++; f5 = fopen (fn5, "w+"); /* open for update, clearing file */ if (f5 == NULL) /* contents */ goto Fail; count++; f6 = fopen (fn6, "a+"); /* open for update, starting at */ if (f6 == NULL) /* end of file */ goto Fail; /* Open two more files, then shut 4 open ones before opening the */ /* last four files. These files will be open in "binary" mode. */ count++; f7 = fopen (fn7, "wb"); /* open binary file for writing */ if (f7 == NULL) goto Fail; count++; f8 = fopen (fn8, "wb"); if (f8 == NULL) goto Fail; count++; i = fclose (f1); /* close the first four files */ if (i == EOF) goto Fail2; count++; i = fclose (f2); if (i == EOF) goto Fail2; count++; i = fclose (f3); if (i == EOF) goto Fail2; count++; i = fclose (f4); if (i == EOF) goto Fail2; count++; f1 = fopen (fn9, "ab"); /* open binary file for appending */ if (f1 == NULL) goto Fail; count++; f2 = fopen (fn10, "wb+"); /* open binary file for update, */ if (f2 == NULL) /* starting at beginning of file */ goto Fail; count++; f3 = fopen (fn11, "wb+"); /* open binary file for update, */ if (f3 == NULL) /* clearing file contents first */ goto Fail; count++; f4 = fopen (fn12, "ab+"); /* open binary file for update, */ if (f4 == NULL) /* starting at end of file */ goto Fail; count++; i = fclose (f1); /* close all of the open files */ if (i == EOF) goto Fail2; count++; i = fclose (f2); if (i == EOF) goto Fail2; count++; i = fclose (f3); if (i == EOF) goto Fail2; count++; i = fclose (f4); if (i == EOF) goto Fail2; count++; i = fclose (f5); if (i == EOF) goto Fail2; count++; i = fclose (f6); if (i == EOF) goto Fail2; count++; i = fclose (f7); if (i == EOF) goto Fail2; count++; i = fclose (f8); if (i == EOF) goto Fail2; printf ("Passed Special Conformance Test 17.2.0.1 "); return; Fail: printf ("count = %d\n", count); perror ("File creation failure in Special Conformance Test 17.2.0.1 "); return; Fail2: printf ("count = %d\n", count); printf ("Error when closing file"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.2.0.2.CC b/Tests/Spec.Conform/SPC17.2.0.2.CC new file mode 100755 index 0000000..00c8c36 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.2.0.2.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 17.2.0.2: Verification of fflush */ /* */ /* Other files needed: spc17.202.exec - EXEC file which flushes the contents */ /* of 12 data files to the printer */ /* spc17.2.0.a - spc17.2.0.l - data files for the test */ /* */ /* Tester needs to verify that the 12 files named spc17.2.0.a - spc17.2.0.l, */ /* and located on the work prefix, are dumped to the printer */ /* */ #include main () { int i, count = 0; FILE *f1, *f2, *f3, *f4, *f5, *f6, *f7, *f8; /* must be able to open */ /* 8 files at a time */ char fn1 [14] = "3/spc17.2.0.a"; /* define filenames */ char fn2 [14] = "3/spc17.2.0.b"; char fn3 [14] = "3/spc17.2.0.c"; char fn4 [14] = "3/spc17.2.0.d"; char fn5 [14] = "3/spc17.2.0.e"; char fn6 [14] = "3/spc17.2.0.f"; char fn7 [14] = "3/spc17.2.0.g"; char fn8 [14] = "3/spc17.2.0.h"; char fn9 [14] = "3/spc17.2.0.i"; char fn10 [14] = "3/spc17.2.0.j"; char fn11 [14] = "3/spc17.2.0.k"; char fn12 [14] = "3/spc17.2.0.l"; count++; f1 = fopen (fn1, "w"); /* open for writing */ if (f1 == NULL) goto Fail; i = fputs ("This is file 3/spc17.2.0.a", f1); if (i == EOF) goto Fail2; i = fflush (f1); if (i == EOF) goto Fail3; count++; f2 = fopen (fn2, "a"); /* open for appending */ if (f2 == NULL) goto Fail; i = fputs ("This is file 3/spc17.2.0.b", f2); if (i == EOF) goto Fail2; i = fflush (f2); if (i == EOF) goto Fail3; count++; f3 = fopen (fn3, "a"); /* open for appending */ if (f3 == NULL) goto Fail; i = fputs ("This is file 3/spc17.2.0.c", f3); if (i == EOF) goto Fail2; i = fflush (f3); if (i == EOF) goto Fail3; count++; f4 = fopen (fn4, "w+"); /* open for update, starting at */ if (f4 == NULL) /* beginning of file */ goto Fail; i = fputs ("This is file 3/spc17.2.0.d", f4); if (i == EOF) goto Fail2; i = fflush (f4); if (i == EOF) goto Fail3; count++; f5 = fopen (fn5, "w+"); /* open for update, clearing file */ if (f5 == NULL) /* contents */ goto Fail; i = fputs ("This is file 3/spc17.2.0.e", f5); if (i == EOF) goto Fail2; i = fflush (f5); if (i == EOF) goto Fail3; count++; f6 = fopen (fn6, "a+"); /* open for update, starting at */ if (f6 == NULL) /* end of file */ goto Fail; i = fputs ("This is file 3/spc17.2.0.f", f6); if (i == EOF) goto Fail2; i = fflush (f6); if (i == EOF) goto Fail3; /* Open two more files, then shut 4 open ones before opening the */ /* last four files. These files will be open in "binary" mode. */ count++; f7 = fopen (fn7, "wb"); /* open binary file for writing */ if (f7 == NULL) goto Fail; i = fprintf (f7, "%f", -43.876); if (i == EOF) goto Fail2; i = fflush (f7); if (i == EOF) goto Fail3; count++; f8 = fopen (fn8, "wb"); /* open binary file for writing */ if (f8 == NULL) goto Fail; i = fprintf (f8, "%d", 32767); if (i == EOF) goto Fail2; i = fflush (f8); if (i == EOF) goto Fail3; count++; i = fclose (f1); /* close the first four files */ if (i == EOF) goto Fail4; count++; i = fclose (f2); if (i == EOF) goto Fail4; count++; i = fclose (f3); if (i == EOF) goto Fail4; count++; i = fclose (f4); if (i == EOF) goto Fail4; count++; f1 = fopen (fn9, "ab"); /* open binary file for appending */ if (f1 == NULL) goto Fail; i = fprintf (f1, "%e", 23.8e+90); if (i == EOF) goto Fail2; i = fflush (f1); if (i == EOF) goto Fail3; count++; f2 = fopen (fn10, "wb+"); /* open binary file for update, */ if (f2 == NULL) /* starting at beginning of file */ goto Fail; i = fprintf (f2, "%c", 0x07); if (i == EOF) goto Fail2; i = fflush (f2); if (i == EOF) goto Fail3; count++; f3 = fopen (fn11, "wb+"); /* open binary file for update, */ if (f3 == NULL) /* clearing file contents first */ goto Fail; i = fprintf (f3, "%%"); if (i == EOF) goto Fail2; i = fflush (f3); if (i == EOF) goto Fail3; count++; f4 = fopen (fn12, "ab+"); /* open binary file for update, */ if (f4 == NULL) /* starting at end of file */ goto Fail; i = fprintf (f4, "%d", count); if (i == EOF) goto Fail2; i = fflush (f4); if (i == EOF) goto Fail3; count++; i = fclose (f1); /* close all of the open files */ if (i == EOF) goto Fail4; count++; i = fclose (f2); if (i == EOF) goto Fail4; count++; i = fclose (f3); if (i == EOF) goto Fail4; count++; i = fclose (f4); if (i == EOF) goto Fail4; count++; i = fclose (f5); if (i == EOF) goto Fail4; count++; i = fclose (f6); if (i == EOF) goto Fail4; count++; i = fclose (f7); if (i == EOF) goto Fail4; count++; i = fclose (f8); if (i == EOF) goto Fail4; printf ("Passed Special Conformance Test 17.2.0.2 "); return; Fail: perror ("File open failure in Special Conformance Test 17.2.0.2 "); goto Out; Fail2: printf ("Error when writing to file\n"); goto Out; Fail3: printf ("Error when flushing file\n"); goto Out; Fail4: printf ("Error when closing file\n"); Out: printf ("count = %d\n", count); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.2.0.3.CC b/Tests/Spec.Conform/SPC17.2.0.3.CC new file mode 100755 index 0000000..1a2a3e2 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.2.0.3.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 17.2.0.3: Verification of freopen */ /* */ /* Other files needed: spc17.2.0.a - spc17.2.0.d - data files for the test */ /* */ /* Tester needs to verify that the files named spc17.2.0.a - spc17.2.0.d, */ /* and located on the work prefix, have previously been created with the */ /* test Special Conformance 17.2.0.2. */ /* */ /* The first action of the test will be to open spc17.2.0.a, and print its */ /* contents on the screen. The tester needs to verify that the contents are */ /* correct. */ /* */ /* The next action is to verify that standard input is working. The tester */ /* will be prompted for a string; this string will then be written to both */ /* standard out and standard error out. The tester needs to verify that the */ /* output strings are correct. */ /* */ /* The test will then redirect standard in, standard out, and standard error */ /* out. The contents of spc17.2.0.b will be sent to the files spc17.0.c, */ /* the new standard out, and spc17.2.0.d, the new standard error out. The */ /* tester needs to verify that the three files are identical. */ /* */ /* Finally, standard in, standard out, and standard error out will be reset */ /* to their original values. The tester will be prompted for a new string */ /* to be entered from the keyboard. The tester needs to verify that the */ /* string is correctly echoed to the screen twice (once for standard out and */ /* once for standard error out). */ /* */ #include #include main () { int i, j; char s [255]; /* input buffer */ FILE *f1, *f2, *f3, *f4; FILE *saveStdin, *saveStdout, *saveStderr; char fn1 [14] = "3/spc17.2.0.a"; /* define filenames */ char fn2 [14] = "3/spc17.2.0.b"; char fn3 [14] = "3/spc17.2.0.c"; char fn4 [14] = "3/spc17.2.0.d"; f1 = fopen (fn1, "r"); /* open for reading */ if (f1 == NULL) goto Fail; i = 0; while ((j = fgetc (f1)) != EOF) /* read successive */ s [i++] = (char) j; /* chars into string */ s [i] = '\0'; printf ("This is the contents of 3/spc17.2.0.a:\n%s\n", s); f1 = freopen (fn2, "a+", f1); /* reassign file pointer */ if (f1 == NULL) goto Fail2; i = fseek (f1, 0L, SEEK_END); /* move to end of file */ if (i) goto Fail5; i = fputs ("This is the second line of file 3/spc17.2.0.b", f1); if (i == EOF) goto Fail3; rewind (f1); i = 0; while ((j = fgetc (f1)) != EOF) /* read successive */ s [i++] = (char) j; /* chars into string */ s [i] = '\0'; printf ("\nThese are the updated contents of 3/spc17.2.0.b:\n%s\n", s); /* This part of the test verifies reopening standard in, standard out, and */ /* standard error out. */ printf ("Please enter a string\n"); /* 1st verify that standard in */ j = 0; /* standard out and standard */ while ((i = fgetc (stdin)) != '\n') /* error out work */ { if (i == EOF) goto Fail7; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail8; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail9; printf ("\n"); saveStdin = stdin; stdin = freopen (fn1, "r", f1); /* reassign standard in */ if (stdin == NULL) goto Fail2; f3 = fopen (fn3, "w"); /* open stream to get new FILE ptr */ if (f3 == NULL) goto Fail; saveStdout = stdout; stdout = freopen (fn3, "w", f3); /* reassign standard out */ if (stdout == NULL) goto Fail2; saveStderr = stderr; f4 = fopen (fn4, "w"); /* open stream to get new FILE ptr */ if (f4 == NULL) goto Fail; stderr = freopen (fn4, "w", f4); /* reassign standard error */ if (stderr == NULL) goto Fail2; i = fscanf (stdin, "%s", s); /* read input string from file */ if (i == EOF) goto Fail7; i = puts (s); /* write string to files */ if (i) goto Fail8; i = fputs (s, stderr); if (i) goto Fail9; /* Now reset standard in, standard out, and standard error, and ensure */ /* they're ok. */ i = fclose (stdin); /* close disk files attached */ if (i == EOF) /* to stdin, stdout, stderr */ goto Fail4; i = fclose (stdout); if (i == EOF) goto Fail4; i = fclose (stderr); if (i == EOF) goto Fail4; stdin = saveStdin; /* reassign standard in */ stdout = saveStdout; /* reassign standard out */ stderr = saveStderr; /* reassign standard error */ printf ("Please enter a string\n"); /* Prompt the tester to input */ j = 0; /* a string & then check that*/ while ((i = fgetc (stdin)) != '\n') /* it's written to stdout & */ { /* stderr */ if (i == EOF) goto Fail7; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = puts (s); if (i) goto Fail8; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail9; printf ("\n"); printf ("Passed Special Conformance Test 17.2.0.3 "); return; Fail: perror ("File open failure in Special Conformance Test 17.2.0.3 "); exit (0); Fail2: printf ("Error when reopening stream\n"); exit (0); Fail3: printf ("Error when writing file\n"); exit (0); Fail4: printf ("Error when closing file\n"); exit (0); Fail5: printf ("Error when seeking file\n"); exit (0); Fail6: printf ("Error when appending to file\n"); exit (0); Fail7: printf ("Error when reading from standard in\n"); exit (0); Fail8: printf ("Error when writing to standard out\n"); exit (0); Fail9: printf ("Error when writing to standard error out\n"); exit (0); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.3.0.1.CC b/Tests/Spec.Conform/SPC17.3.0.1.CC new file mode 100755 index 0000000..a9ec202 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.3.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.3.0.1: Verification of buffering facility */ /* setvbuf. */ /* */ /* Tester needs to verify that the file 3/tmp is created and contains the */ /* following characters: ASCII $20 through $6E, plus ~ and } */ #include main () { FILE *f1; /* file pointer */ char buf [80]; /* buffer */ int i, j; f1 = fopen ("3/tmp", "w"); /* create file to work on */ if (f1 == NULL) goto Fail1; i = setvbuf (f1, buf, _IOFBF, 80); /* allocate write buffer for file */ if (i) goto Fail2; for (i = 0; i < 79; i++) /* write 79 charaters to the file */ { j = fputc ( (char) (i + 0x20), f1); if (j == EOF) goto Fail3; } for (j = 0x20, i = 0; i < 79; i++) /* check buffer contents */ if (buf [i] != j++) goto Fail; j = fputc ('~', f1); /* 2 more chars should cause*/ if (j == EOF) /* buffer to be flushed */ goto Fail3; j = fputc ('}', f1); if (j == EOF) goto Fail3; if (buf [0] != '}') goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail4; printf ("Passed Special Conformance Test 17.3.0.1\n"); return; Fail: printf ("Failed Special Conformance Test 17.3.0.1\n"); return; Fail1: printf ("Could not open tmp file for Special Conformance Test 17.3.0.1\n"); return; Fail2: printf ("Could not allocate buffer for Special Conformance Test 17.3.0.1\n"); return; Fail3: printf ("Could not write to file for Special Conformance Test 17.3.0.1\n"); return; Fail4: printf ("Could not close file for Special Conformance Test 17.3.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.3.0.2.CC b/Tests/Spec.Conform/SPC17.3.0.2.CC new file mode 100755 index 0000000..d748041 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.3.0.2.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.3.0.2: Verification of buffering facility */ /* setvbuf using line buffering. */ /* */ /* Tester needs to verify that the file 3/tmp is created and contains the */ /* 2 lines: all good people are here */ /* ...and maybe some 'bad' ones, too */ #include #include main () { FILE *f1; /* file pointer */ char buf [80]; /* buffer */ int i, j; f1 = fopen ("3/tmp", "w"); /* create file to work on */ if (f1 == NULL) goto Fail1; i = setvbuf (f1, buf, _IOLBF, 80); /* allocate write buffer for file */ if (i) goto Fail2; i = fputs ("all good people are here\n", f1); /* write 1 line to the file */ if (i) goto Fail3; if (strncmp (buf, "all good people are here", 24)) /* check buffer */ goto Fail; /* contents */ i = fputs ("...and maybe some 'bad' ones, too\n", f1);/* write 1 more line */ if (i) /* to the file */ goto Fail3; /* Check buffer contents again */ if (strncmp (buf, "...and maybe some 'bad' ones, too", 33)) goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail4; printf ("Passed Special Conformance Test 17.3.0.2\n"); return; Fail: printf ("Failed Special Conformance Test 17.3.0.2\n"); return; Fail1: printf ("Could not open tmp file for Special Conformance Test 17.3.0.2\n"); return; Fail2: printf ("Could not allocate buffer for Special Conformance Test 17.3.0.2\n"); return; Fail3: printf ("Could not write to file for Special Conformance Test 17.3.0.2\n"); return; Fail4: printf ("Could not close file for Special Conformance Test 17.3.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.3.0.3.CC b/Tests/Spec.Conform/SPC17.3.0.3.CC new file mode 100755 index 0000000..9ebc459 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.3.0.3.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.3.0.3: Verification of buffering facility */ /* setvbuf: no buffering */ /* */ /* Tester needs to verify that the file 3/tmp is created and contains the */ /* lower case alphabetic characters. */ #include main () { FILE *f1; /* file pointer */ int i, j; char c; f1 = fopen ("3/tmp", "w"); /* create file to work on */ if (f1 == NULL) goto Fail1; i = setvbuf (f1, NULL, _IONBF, 0); /* allocate write buffer for file */ if (i) goto Fail2; for (c = 'a', i = 0; i < 26; i++, c++) /* write 26 charaters to the file */ { j = fputc (c, f1); if (j == EOF) goto Fail3; } i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail4; printf ("Passed Special Conformance Test 17.3.0.3\n"); return; Fail1: printf ("Could not open tmp file for Special Conformance Test 17.3.0.3\n"); return; Fail2: printf ("setvbuf command failed in Special Conformance Test 17.3.0.3\n"); return; Fail3: printf ("Could not write to file for Special Conformance Test 17.3.0.3\n"); return; Fail4: printf ("Could not close file for Special Conformance Test 17.3.0.3\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.3.0.4.CC b/Tests/Spec.Conform/SPC17.3.0.4.CC new file mode 100755 index 0000000..82976a6 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.3.0.4.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.3.0.4: Verification of buffering facility */ /* setbuf. */ /* */ /* Tester needs to verify that the file 3/tmp is created and contains the */ /* following characters: ASCII $20 through $6E, plus ~ and } */ #include static char buf [BUFSIZ]; main () { int count = 0; FILE *f1; /* file pointer */ char ch; int i, j; long L; count++; f1 = fopen ("3/tmp", "w"); /* create file to work on */ if (f1 == NULL) goto Fail1; setbuf (f1, buf); /* allocate write buffer for file */ /* just hope it works */ for (ch = ' ', i = 0; i < 30; ch++, i++) /* write 30 chars to the file */ { j = fputc (ch, f1); if (j == EOF) goto Fail2; } for (j = 0x20, i = 0; i < 30; i++) /* check buffer contents */ if (buf [i] != j++) goto Fail; count++; for (L = 30; L < BUFSIZ; L++) /* fill buffer so that it'll */ { /* be flushed */ j = fputc ('a', f1); if (j == EOF) goto Fail2; } j = fputc ('~', f1); /* write 1 more char to buf */ if (j == EOF) /* & then check contents */ goto Fail2; if (buf [0] != '~') goto Fail; i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail3; printf ("Passed Special Conformance Test 17.3.0.4\n"); return; Fail: printf ("Failed Special Conformance Test 17.3.0.4: count = %d\n", count); return; Fail1: printf ("Could not open tmp file for Special Conformance Test 17.3.0.4\n"); return; Fail2: printf ("Could not write to file for Special Conformance Test 17.3.0.4\n"); return; Fail3: printf ("Could not close file for Special Conformance Test 17.3.0.4\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.3.0.5.CC b/Tests/Spec.Conform/SPC17.3.0.5.CC new file mode 100755 index 0000000..e45221d --- /dev/null +++ b/Tests/Spec.Conform/SPC17.3.0.5.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 17.3.0.5: Verification of buffering facility */ /* setbuf. */ /* */ /* Tester needs to verify that the file 3/tmp is created and contains the */ /* 26 uppercase alphabetic characters. */ /* */ #include main () { FILE *f1; /* file pointer */ int i, j; char ch; f1 = fopen ("3/tmp", "w"); /* create file to work on */ if (f1 == NULL) goto Fail1; setbuf (f1, NULL); /* specify no buffering for file */ /* just hope it works */ for (ch = 'A', i = 0; i < 26; ch++, i++) /* write 79 chars to the file */ { j = fputc (ch, f1); if (j == EOF) goto Fail2; } i = fclose (f1); /* close the file and quit */ if (i == EOF) goto Fail3; printf ("Passed Special Conformance Test 17.3.0.5\n"); return; Fail: printf ("Failed Special Conformance Test 17.3.0.5\n"); return; Fail1: printf ("Could not open tmp file for Special Conformance Test 17.3.0.5\n"); return; Fail2: printf ("Could not write to file for Special Conformance Test 17.3.0.5\n"); return; Fail3: printf ("Could not close file for Special Conformance Test 17.3.0.5\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.6.0.1.CC b/Tests/Spec.Conform/SPC17.6.0.1.CC new file mode 100755 index 0000000..92df9cf --- /dev/null +++ b/Tests/Spec.Conform/SPC17.6.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.6.0.1: Verification of fgetc, getc, getchar, */ /* and ungetc with standard input */ /* */ /* The first action of the test is to verify that standard input is working. */ /* The tester will be prompted for a string three times (once each for fgetc,*/ /* getc, and getchar); this string will then be echoed to standard out and to*/ /* standard error out. The tester needs to verify that the output string is */ /* correct. */ /* */ /* The test will then redirect standard input to a temporary file created on */ /* the work prefix. The tester needs to verify that the characters sent to */ /* standard output and standard error output are the lower case alphabetic */ /* characters. */ /* */ /* Finally, standard input is reset to the keyboard. The tester will be */ /* prompted for a new string to be entered from the keyboard. The tester */ /* needs to verify that the string is correctly echoed to the screen. */ #include #include main () { int i, j; char s [255], ch; FILE *f1, *saveStdin; /* This part of the test that standard input and standard output are working */ printf ("Please enter a string\n"); /* test fgetc with standard in */ j = 0; while ((i = fgetc (stdin)) != '\n') { if (i == EOF) goto Fail3; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail4; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail5; printf ("\n"); printf ("Please enter a string\n"); /* test getc with standard in */ j = 0; while ((i = getc (stdin)) != '\n') { if (i == EOF) goto Fail3; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail4; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail5; printf ("\n"); printf ("Please enter a string\n"); /* test getchar */ j = 0; while ( (i = getchar ()) != '\n' ) { if (i == EOF) goto Fail3; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail4; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail5; printf ("\n"); /* Now test fgetc, getc, and getchar by redirecting standard input. */ f1 = fopen ("3/tmp", "w"); /* create new file */ if (f1 == NULL) goto Fail; for (ch = 'a', i = 0; i < 26; i++) { j = fputc (ch, f1); if ( (char) j != ch ) goto Fail2; ch++; } j = fputc ('\n', f1); if (j != '\n') goto Fail2; saveStdin = stdin; stdin = freopen ("3/tmp", "r", f1); /* reassign standard in */ if (stdin == NULL) goto Fail1; j = 0; /* read file with fgetc */ while ( (i = fgetc (stdin)) != EOF) { putchar(i); s [j++] = i; } s [j] = '\0'; if (! feof (stdin) ) goto Fail3; printf ("The string read from the temp file is:\n"); i = fputs (s, stdout); if (i) goto Fail4; i = fputs (s, stderr); if (i) goto Fail5; rewind (stdin); /* read file with getc */ j = 0; while ( (i = getc (stdin)) != EOF) s [j++] = i; s [j] = '\0'; if (! feof (stdin) ) goto Fail3; printf ("The string read from the temp file is:\n"); i = fputs (s, stdout); if (i) goto Fail4; i = fputs (s, stderr); if (i) goto Fail5; rewind (stdin); /* read file with getchar */ j = 0; while ( (i = getchar ()) != EOF) s [j++] = i; s [j] = '\0'; if (! feof (stdin) ) goto Fail3; printf ("The string read from the temp file is:\n"); i = fputs (s, stdout); if (i) goto Fail4; i = fputs (s, stderr); if (i) goto Fail5; /* Now reset standard input and ensure it's ok. */ stdin = saveStdin; /* reassign standard in */ printf ("Please enter a string\n"); /* read standard in with fgetc */ j = 0; while ((i = fgetc (stdin)) != '\n') { if (i == EOF) goto Fail3; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail4; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail5; printf ("\n"); printf ("Please enter a string\n"); /* read standard in with getc */ j = 0; while ((i = getc (stdin)) != '\n') { if (i == EOF) goto Fail3; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail4; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail5; printf ("\n"); printf ("Please enter a string\n"); /* read standard in with getchar */ j = 0; while ( (i = getchar ()) != '\n' ) { if (i == EOF) goto Fail3; s [j++] = i; } s [j] = '\0'; printf ("The string entered is:\n"); i = fputs (s, stdout); if (i) goto Fail4; printf ("\n"); i = fputs (s, stderr); if (i) goto Fail5; printf ("\n"); return; Fail: perror ("File open failure in Special Conformance Test 17.6.0.1 "); exit (0); Fail1: printf ("Error when reopening stream\n"); exit (0); Fail2: printf ("Error when writing file\n"); exit (0); Fail3: printf ("Error when reading from standard in\n"); exit (0); Fail4: printf ("Error when writing to standard out\n"); exit (0); Fail5: printf ("Error when writing to standard error out\n"); exit (0); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC17.7.0.1.CC b/Tests/Spec.Conform/SPC17.7.0.1.CC new file mode 100755 index 0000000..c618e74 --- /dev/null +++ b/Tests/Spec.Conform/SPC17.7.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 17.7.0.1: Verification of gets function */ /* */ /* The tester will be asked to enter some strings. The strings will */ /* then be echoed to the screen. The strings should be verified */ /* that they are the same as those entered. */ #include main () { int i; char string [20] = ""; /* initialize input string to null string */ char *strPtr; printf ("Please enter a string which is shorter than 20 characters.\n"); printf ("Signal string is complete with CR.\n"); strPtr = gets (string); /* test reading until CR seen */ if (strPtr == NULL) goto Fail; printf ("The string entered was:\n"); i = puts (string); if (i) goto Fail1; printf ("This message should appear immediately below the string.\n"); printf ("Please enter only the end-of-file character sequence (CTRL@)\n"); strPtr = gets (string); /* test reading with EOF seen before */ if (strPtr != NULL) /* any other characters */ goto Fail2; if (! feof (stdin)) goto Fail3; i = fseek (stdin, 0L, SEEK_CUR); /* clear EOF indication */ if (i) goto Fail4; printf ("The first string entered was:\n"); /* string shouldn't change */ i = puts (string); if (i) goto Fail1; printf ("\n"); printf ("Please enter a string which is shorter than 20 characters.\n"); strPtr = gets (string); /* test reading until CR seen */ if (strPtr == NULL) goto Fail; printf ("The string entered was:\n"); i = puts (string); if (i) goto Fail1; printf ("This message should appear immediately below the string.\n"); return 0; Fail: printf ("Failed Special Conformance Test 17.7.0.1\n"); return 0; Fail1: printf ("Unable to write to standard out\n"); return 0; Fail2: printf ("Reading EOF before any other chars doesn't return NULL ptr\n"); return 0; Fail3: printf ("EOF for standard input not detected\n"); return 0; Fail4: printf ("Unable to FSEEK on stdin\n"); return 0; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC2.1.0.1.CC b/Tests/Spec.Conform/SPC2.1.0.1.CC new file mode 100755 index 0000000..b5bceb3 --- /dev/null +++ b/Tests/Spec.Conform/SPC2.1.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 2.1.0.1: Verification of character set */ #include main () { int c; /* Read chars from keyboard; echo to a device. Tester must */ /* check correct output of characters. The test should be */ /* repeated 3 times, with output going to console, to printer */ /* and to a file. */ while ((c = getchar ()) != EOF) putchar (c); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC20.2.0.1.CC b/Tests/Spec.Conform/SPC20.2.0.1.CC new file mode 100755 index 0000000..e3ae276 --- /dev/null +++ b/Tests/Spec.Conform/SPC20.2.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 20.2.0.1: Verification of time, asctime, ctime, */ /* localtime, gmtime, mktime, difftime */ /* */ /* The tester needs to verify that the printed time is accurate for the */ /* current clock setting of machine. */ #include #include main () { time_t secondTime, theTime, *tptr = &theTime; char *timeString; struct tm *TM; double d; theTime = time (tptr); /* call time to get current date & time */ if (theTime == -1) /* represented as an integral type */ goto Fail; if (theTime != *tptr) goto Fail; /* Call ctime to get current date/time in the form: */ /* Day Mon 99 99:99:99 yyyy\n\0 where Day = day of week; Mon = month; */ /* 99 = day of month; 99:99:99 = current hour:min:sec; yyyy = current year */ timeString = ctime (tptr); printf ("The current date/time is: %s\n", timeString); /* Call localtime and gmtime and then echo the fields to the screen. */ TM = localtime (tptr); if (TM == NULL) goto Fail; printf ("localtime is:\n"); printf ("sec = %d min = %d hour = %d day = %d month = %d year = %d\n", TM->tm_sec, TM->tm_min, TM->tm_hour, TM->tm_mday, TM->tm_mon, TM->tm_year); printf ("day of week = %d day of year = %d not daylight savings = %d\n\n", TM->tm_wday, TM->tm_yday, TM->tm_isdst); TM = gmtime (tptr); if (TM == NULL) goto Fail; printf ("gmtime is:\n"); printf ("sec = %d min = %d hour = %d day = %d month = %d year = %d\n", TM->tm_sec, TM->tm_min, TM->tm_hour, TM->tm_mday, TM->tm_mon, TM->tm_year); printf ("day of week = %d day of year = %d not daylight savings = %d\n\n", TM->tm_wday, TM->tm_yday, TM->tm_isdst); /* Test mktime: should return original time as returned by time. */ secondTime = mktime (TM); if (secondTime != theTime) goto Fail; /* Test asctime: should return same time as returned by ctime. */ timeString = asctime (TM); printf ("The current date/time is: %s\n", timeString); /* Test difftime. Value returned should be zero. */ d = difftime (theTime, secondTime); if (d != 0.0) goto Fail; return; Fail: printf ("Call to a time function in spc20.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC21.1.0.1.CC b/Tests/Spec.Conform/SPC21.1.0.1.CC new file mode 100755 index 0000000..ad39d55 --- /dev/null +++ b/Tests/Spec.Conform/SPC21.1.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 21.1.0.1: Verification of assert, ndebug macros */ /* */ /* The tester should verify that the program halts with the error message: */ /* "Assertion failed: file spc21.1.0.1.cc, line 14" */ #undef NDEBUG #include main () { assert (0); printf ("Failed Special Conformance Test 21.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC21.2.0.1.CC b/Tests/Spec.Conform/SPC21.2.0.1.CC new file mode 100755 index 0000000..b50d608 --- /dev/null +++ b/Tests/Spec.Conform/SPC21.2.0.1.CC @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 21.2.0.1: Verification of system function */ /* */ /* The tester should verify that the shell's CATALOG command is executed */ /* and that status is zero if the command worked. */ /* */ #include main () { int i; i = system ("catalog\r"); exit (i); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC22.1.0.1.CC b/Tests/Spec.Conform/SPC22.1.0.1.CC new file mode 100755 index 0000000..8ddb2cf --- /dev/null +++ b/Tests/Spec.Conform/SPC22.1.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 22.1.0.1: Verification of argv, argc */ /* */ /* Other files needed: spc22.101.exec - EXEC file which compiles, */ /* links, and executes test */ /* file with 3 parameters */ int main (int argc, char *argv []) { int count = 0; count++; if (argc != 4) goto Fail; count++; if (strcmp (argv [0], "3/spc22.1")) goto Fail; count++; if (strcmp (argv [1], "cat")) goto Fail; count++; if (strcmp (argv [2], "dog")) goto Fail; count++; if (strcmp (argv [3], "run")) goto Fail; printf ("Passed Special Conformance Test 22.1.0.1\n"); return 0; Fail: printf ("count = %d\n", count); printf ("Failed Special Conformance Test 22.1.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC22.101.EXEC b/Tests/Spec.Conform/SPC22.101.EXEC new file mode 100755 index 0000000..996d166 --- /dev/null +++ b/Tests/Spec.Conform/SPC22.101.EXEC @@ -0,0 +1 @@ +cmpl spc22.1.0.1.cc keep=3/spc22.1 if {status} == 0 3/spc22.1 cat dog run else echo Unable to compile/link Special Conformance Test 22.1.0.1 end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC23.2.0.1.CC b/Tests/Spec.Conform/SPC23.2.0.1.CC new file mode 100755 index 0000000..3ad19df --- /dev/null +++ b/Tests/Spec.Conform/SPC23.2.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 23.2.0.1: Verification of commandline */ /* */ /* Other files needed: spc23.201.exec - EXEC file which compiles, */ /* links, and executes test */ /* file with parameters */ #include main () { char *cmdLine; cmdLine = commandline (); if (strcmp (cmdLine, "3/spc23.2 one two three four")) goto Fail; printf ("Passed Special Conformance Test 23.2.0.1\n"); return; Fail: printf ("Failed Special Conformance Test 23.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC23.201.EXEC b/Tests/Spec.Conform/SPC23.201.EXEC new file mode 100755 index 0000000..9d45734 --- /dev/null +++ b/Tests/Spec.Conform/SPC23.201.EXEC @@ -0,0 +1 @@ +cmpl spc23.2.0.1.cc keep=3/spc23.2 if {status} == 0 3/spc23.2 one two three four else echo Unable to compile/link Special Conformance Test 23.2.0.1 end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.0.1.CC b/Tests/Spec.Conform/SPC25.0.1.CC new file mode 100755 index 0000000..d8c553e --- /dev/null +++ b/Tests/Spec.Conform/SPC25.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 25.0.1: Verification of mini-assembler exprs. */ /* */ /* Other files needed: spc25.1.exec - EXEC file which separately compiles, */ /* links, and executes the two files */ /* comprising this test */ /* spc25.1.1.cc - Separately compiled file which */ /* contains global data and routines */ /* accessed by the main program */ /* spc25.1.h - Header file containing global */ /* declarations for second source file */ #include #include "spc25.1.h" static int i1 = 33; main () { int count = 0, i; char *chPtr; int *iPtr; long *lPtr; unsigned char *uchPtr; unsigned int *uiPtr; unsigned long *ulPtr; /* Call routines to initialize global arrays. Verify initialization. */ count++; chPtr = Init_Ch (ch0); if ((*chPtr != 'e') || (chPtr [1] != 'd') || (chPtr [2] != 'c')) goto Fail; count++; iPtr = Init_Int (i0); if ((*iPtr != 10) || (iPtr [1] != 20) || (iPtr [2] != 30)) goto Fail; count++; lPtr = Init_Long (L0); if ((*lPtr != 0) || (lPtr [1] != 100) || (lPtr [2] != 200)) goto Fail; count++; uchPtr = Init_UCh (); if ((*uchPtr != 'r') || (uchPtr [1] != 'q') || (uchPtr [2] != 'p')) goto Fail; count++; uiPtr = Init_UI (ui0); if ((*uiPtr != 0) || (uiPtr [1] != 16) || (uiPtr [2] != 32)) goto Fail; count++; ulPtr = Init_UL (ul0); if ((*ulPtr != 0x777) || (ulPtr [1] != 0x778) || (ulPtr [2] != 0x779)) goto Fail; asm { bra Test uch1: dcb 't' /* Test expressions */ Test: lda i1 sta i cmp #33 bne Err lda uch1 and #0x00FF sta i cmp #0x0074 bne Err lda [iPtr] cmp #10 beq Out Err: inc count jmp Fail } Out: printf ("Passed Conformance Test 25.0.1\n"); return; Fail: printf ("count = %d i = %d\n", count, i); printf ("Failed Conformance Test 25.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.0.2.CC b/Tests/Spec.Conform/SPC25.0.2.CC new file mode 100755 index 0000000..a118556 --- /dev/null +++ b/Tests/Spec.Conform/SPC25.0.2.CC @@ -0,0 +1 @@ +/* Special Conformance Test 25.0.2: Verification of long addressing in mini- */ /* assembler when using large memory model */ /* */ /* Other files needed: spc25.2.exec - EXEC file which separately compiles, */ /* links, and executes the two files */ /* comprising this test */ /* spc25.2.1.cc - Separately compiled file which */ /* contains global data and routines */ /* accessed by the main program */ #pragma memorymodel 1 #include static int i1 = 33; extern char ch0 []; extern int i0 []; extern char * Init_Ch (void); extern int * Init_Int (int i []); main () { char *chPtr; int *iPtr; int count = 0; /* Call routines to initialize global arrays. Verify initialization. */ count++; chPtr = Init_Ch (); if ((*chPtr != 'e') || (chPtr [1] != 'd') || (chPtr [2] != 'c')) goto Fail; count++; iPtr = Init_Int (i0); if ((*iPtr != 10) || (iPtr [1] != 20) || (iPtr [2] != 30)) goto Fail; asm { bra Test uch1: dcb 't' /* Test expressions */ Test: lda i1 cmp #33 bne Err lda uch1 and #0x00FF cmp #0x0074 bne Err lda [iPtr] cmp #10 beq Out Err: inc count jmp Fail } Out: printf ("Passed Conformance Test 25.0.2\n"); return; Fail: printf ("count = %d\n", count); printf ("Failed Conformance Test 25.0.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.1.1.CC b/Tests/Spec.Conform/SPC25.1.1.CC new file mode 100755 index 0000000..b0e28be --- /dev/null +++ b/Tests/Spec.Conform/SPC25.1.1.CC @@ -0,0 +1 @@ +/* Second file comprising Special Conformance Test 25.0.1 */ #define SIZE 3 char ch0 [3]; /* global integers */ int i0 [3]; long L0 [3]; unsigned char uch0 [3]; unsigned int ui0 [3]; unsigned long ul0 [3]; /* global functions */ /*****************************************************************************/ char * Init_Ch (char ch []) { char * chPtr = ch; asm { lda #<'c' /* init starting value for array */ sep #0x20 /* set the accumulator to 8 bits */ ldy #SIZE Top: dey ; loop to initialize ch array bmi Out sta [chPtr],Y inc A bra Top Out: rep #0x20 /* reset accumulator to 16 bits */ } return chPtr; } /*****************************************************************************/ int * Init_Int (int i []) { int j, *iptr = i; asm { lda #10 /* init starting value for array */ sta j ldx #SIZE ldy #0 Top: sta [iptr],Y ; loop to initialize i array lda j clc adc #10 sta j iny iny dex bne Top } return (iptr); } /*****************************************************************************/ long * Init_Long (long L []) { int j; for (j = 0; j < SIZE; j++) L [j] = j * 100; return (L); } /*****************************************************************************/ unsigned char * Init_UCh (void) { asm { lda #<'p' /* init starting value for array */ sep #0x20 /* set the accumulator to 8 bits */ ldx #SIZE Top: dex ; loop to initialize uch0 array bmi Out sta uch0,X inc A bra Top Out: rep #0x20 /* reset accumulator to 16 bits */ } return (uch0); } /*****************************************************************************/ unsigned int * Init_UI (unsigned int ui []) { int j; for (j = 0; j < SIZE; j++) ui [j] = (unsigned int) (j << 4); return (ui); } /*****************************************************************************/ unsigned long * Init_UL (unsigned long ul []) { int j; for (j = 0; j < SIZE; j++) ul [j] = (unsigned long) (j + 0x777); return (ul); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.1.EXEC b/Tests/Spec.Conform/SPC25.1.EXEC new file mode 100755 index 0000000..f4ed1f5 --- /dev/null +++ b/Tests/Spec.Conform/SPC25.1.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 25.0.1 * unset exit compile spc25.0.1.cc keep=3/spc25.1 if {status} == 0 compile spc25.1.1.cc keep=3/spc25.1.1 if {status} == 0 link 3/spc25.1 3/spc25.1.1 keep=3/spc25.1 if {status} == 0 3/spc25.1 else echo Unable to link Special Conformance Test 25.0.1 end else echo Unable to compile file spc25.1.1.cc end else echo Unable to compile file spc25.0.1.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.1.H b/Tests/Spec.Conform/SPC25.1.H new file mode 100755 index 0000000..53a580e --- /dev/null +++ b/Tests/Spec.Conform/SPC25.1.H @@ -0,0 +1 @@ +/* Global declarations for Special Conformance Test 25.0.1 */ extern char ch0 [3]; extern int i0 [3]; extern long L0 [3]; extern unsigned char uch0 [3]; extern unsigned int ui0 [3]; extern unsigned long ul0 [3]; extern char * Init_Ch (char ch []); extern int * Init_Int (int i []); extern long * Init_Long (long L []); extern unsigned char * Init_UCh (void); extern unsigned int * Init_UI (unsigned int ui []); extern unsigned long * Init_UL (unsigned long ul []); \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.2.1.CC b/Tests/Spec.Conform/SPC25.2.1.CC new file mode 100755 index 0000000..b9dd4dc --- /dev/null +++ b/Tests/Spec.Conform/SPC25.2.1.CC @@ -0,0 +1 @@ +/* Second file comprising Special Conformance Test 25.0.2 */ #pragma memorymodel 1 #define SIZE 3 char ch0 [3]; /* global integers */ int i0 [3]; /* global functions */ /*****************************************************************************/ char * Init_Ch (void) { asm { lda #'c' /* init starting value for array */ sep #0x20 /* set the accumulator to 8 bits */ ldx #SIZE Top: dex ; loop to initialize uch0 array bmi Out sta ch0,X inc A bra Top Out: rep #0x20 /* reset accumulator to 16 bits */ } return (ch0); } /*****************************************************************************/ int * Init_Int (int i []) { int j, *iptr = i; asm { lda #10 /* init starting value for array */ sta j ldx #SIZE ldy #0 Top: sta [iptr],Y ; loop to initialize i array lda j clc adc #10 sta j iny iny dex bne Top } return (iptr); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC25.2.EXEC b/Tests/Spec.Conform/SPC25.2.EXEC new file mode 100755 index 0000000..e1eacb1 --- /dev/null +++ b/Tests/Spec.Conform/SPC25.2.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 25.0.2 * unset exit compile spc25.0.2.cc keep=3/spc25.2 set errNo {status} if {errNo} == 0 compile spc25.2.1.cc keep=3/spc25.2.1 set errNo {status} if {errNo} == 0 link 3/spc25.2 3/spc25.2.1 keep=3/spc25.2 set errNo {status} if {errNo} == 0 3/spc25.2 else echo Unable to link Special Conformance Test 25.0.2 end else echo Unable to compile file spc25.2.1.cc end else echo Unable to compile file spc25.0.2.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3.3.4.1.CC b/Tests/Spec.Conform/SPC3.3.4.1.CC new file mode 100755 index 0000000..fa771fe --- /dev/null +++ b/Tests/Spec.Conform/SPC3.3.4.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 3.3.4.1: Verification of __DATE__ and __TIME__ */ /* predefined macros */ /* */ /* The user should verify that the __DATE__ macro returns the computer's */ /* current clock date, in the form: Mmm dd yyyy. The user should also */ /* verify that the __TIME__ macro return the computer's current clock time */ /* in the form: hh:mm:ss. */ main () { printf ("The current date is: '%s'\n", __DATE__); printf ("The current time is: '%s'\n", __TIME__); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3.4.0.1.CC b/Tests/Spec.Conform/SPC3.4.0.1.CC new file mode 100755 index 0000000..7e53b73 --- /dev/null +++ b/Tests/Spec.Conform/SPC3.4.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 3.4.0.1: Verification of #include command. */ /* First run the EXEC file spc3401.exec */ /* */ /* Other files needed: cfile1 */ /* libfile2 */ /* ufile1 */ /* userfile2 */ #define libFile(x) #define userFile(x) x #include libFile(cfile1) #include userFile("ufile1") #include "userfile2" #include \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3.4.0.2.CC b/Tests/Spec.Conform/SPC3.4.0.2.CC new file mode 100755 index 0000000..dab720a --- /dev/null +++ b/Tests/Spec.Conform/SPC3.4.0.2.CC @@ -0,0 +1 @@ +/* Special Conformance Test 3.4.0.2: Ensure #include files can be nested to */ /* a depth of at least 8 */ /* */ /* Other files needed: spc34021, spc34022, spc34023, spc34024, spc34025 */ /* spc34026, spc34027, spc34028 */ #include "spc34021" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3.6.0.1.CC b/Tests/Spec.Conform/SPC3.6.0.1.CC new file mode 100755 index 0000000..342a700 --- /dev/null +++ b/Tests/Spec.Conform/SPC3.6.0.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 3.6.0.1: Test explicit line numbering (#line) */ #pragma debug 9 /* enable range checking and trace back */ void Sub (void) { int a [4080]; /* ensure stack overflow into SANE's area */ } #line 9999 /* expect trace back to report error on line */ /* 9999+4 (call to Sub) */ main () { Sub (); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3.6.0.2.CC b/Tests/Spec.Conform/SPC3.6.0.2.CC new file mode 100755 index 0000000..f42ea54 --- /dev/null +++ b/Tests/Spec.Conform/SPC3.6.0.2.CC @@ -0,0 +1 @@ +/* Special Conformance Test 3.6.0.2: Test explicit line numbering (#line) */ /* with a filename */ #define lineNum(x) x #pragma debug 9 /* enable range checking and trace back */ void Sub (void) { int a [4080]; /* ensure stack overflow into SANE's area */ } #line lineNum(88) "noFile" /* expect trace back to report error on line */ /* 91 (call to Sub), in file noFile */ Sub2() { Sub(); } main () { Sub2 (); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3.6.0.3.CC b/Tests/Spec.Conform/SPC3.6.0.3.CC new file mode 100755 index 0000000..ea2b254 --- /dev/null +++ b/Tests/Spec.Conform/SPC3.6.0.3.CC @@ -0,0 +1 @@ +/* Special Conformance Test 3.6.0.3: Test explicit line numbering (#line) */ /* with filenames */ #include #define FileName(x) x #define LINE_NUM 10 #line LINE_NUM FileName ("onemorefile") main () { if (strcmp (__FILE__, "onemorefile")) { printf ("Failed Special Conformance Test 3.6.0.3\n"); printf ("Macro substitution in LINE fails\n"); printf ("__FILE__ = %s\n", __FILE__); } else printf ("Passed Special Conformance Test 3.6.0.3\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC3401.EXEC b/Tests/Spec.Conform/SPC3401.EXEC new file mode 100755 index 0000000..1d1a04f --- /dev/null +++ b/Tests/Spec.Conform/SPC3401.EXEC @@ -0,0 +1 @@ +copy -c cfile1 2/orcacdefs copy -c libfile2 2/orcacdefs \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34021 b/Tests/Spec.Conform/SPC34021 new file mode 100755 index 0000000..23c2985 --- /dev/null +++ b/Tests/Spec.Conform/SPC34021 @@ -0,0 +1 @@ +/* First included file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34022" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34022 b/Tests/Spec.Conform/SPC34022 new file mode 100755 index 0000000..0740e08 --- /dev/null +++ b/Tests/Spec.Conform/SPC34022 @@ -0,0 +1 @@ +/* Second include file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34023" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34023 b/Tests/Spec.Conform/SPC34023 new file mode 100755 index 0000000..e9af0f2 --- /dev/null +++ b/Tests/Spec.Conform/SPC34023 @@ -0,0 +1 @@ +/* Third include file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34024" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34024 b/Tests/Spec.Conform/SPC34024 new file mode 100755 index 0000000..536a8ad --- /dev/null +++ b/Tests/Spec.Conform/SPC34024 @@ -0,0 +1 @@ +/* Fouth include file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34025" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34025 b/Tests/Spec.Conform/SPC34025 new file mode 100755 index 0000000..0956a38 --- /dev/null +++ b/Tests/Spec.Conform/SPC34025 @@ -0,0 +1 @@ +/* Fifth include file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34026" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34026 b/Tests/Spec.Conform/SPC34026 new file mode 100755 index 0000000..9cea25c --- /dev/null +++ b/Tests/Spec.Conform/SPC34026 @@ -0,0 +1 @@ +/* Sixth include file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34027" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34027 b/Tests/Spec.Conform/SPC34027 new file mode 100755 index 0000000..6c4e36c --- /dev/null +++ b/Tests/Spec.Conform/SPC34027 @@ -0,0 +1 @@ +/* Seventh include file for Special Conformance Test spc3.4.0.2.cc */ #include "spc34028" \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC34028 b/Tests/Spec.Conform/SPC34028 new file mode 100755 index 0000000..c73ea96 --- /dev/null +++ b/Tests/Spec.Conform/SPC34028 @@ -0,0 +1 @@ +/* Final include file for Special Conformance Test spc3.4.0.2.cc */ main () { printf ("Passed Special Conformance Test 3.4.0.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.3.0.1.CC b/Tests/Spec.Conform/SPC4.3.0.1.CC new file mode 100755 index 0000000..ca2a871 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.3.0.1.CC @@ -0,0 +1 @@ +/*****************************************************************************/ /* */ /* Special Conformance Test 4.3.0.1: Ensure static variables and functions */ /* are not passed to the linker, and that */ /* extern variables and functions are */ /* passed to the linker */ /* */ /* Other files needed: spc4301.h - header file for separate compilation */ /* spc4301.1.cc - separately compiled file */ /* spc4301.2.cc - separately compiled file */ /* spc4301.exec - controls compilation and linking */ /* {workDisk}/spc4301.symt - linker's global symbol */ /* table for spc4.3.0.1.cc */ /* */ /* Special instructions: Use the EXEC file spc4301.exec to separately */ /* compile and link the three files. A symbol table */ /* is produced in the output file {workDisk}/ */ /* spc4301.symt. The tester should use the linker's */ /* symbol table to verify that only the extern */ /* functions and variables are in the global symbol */ /* table. In addition, the EXEC file will try to */ /* execute the program. If all is well, a Pass/Fail */ /* message will be written to standard out. */ /* */ /* The global functions are: ChangeChar, L0 */ /* The global variables are: real, i, longNum */ /* */ /*****************************************************************************/ #include #include "spc4301.h" main () { int count = 0; static extended E1 (double x, float y); static char ch; char *chPtr; extern int i; extern long L0 (int *j); count++; i = 0; while (chArray [i] != '\0') { ChangeChar (&chArray [i]); ++i; } chPtr = chArray; if ((strcmp (chPtr, "bcde")) != 0) goto Fail; count++; real = E1 (2.1, 1.5); if ( (fabs (real - 3.15)) > 0.1 ) goto Fail; count++; ch = F1 (2.3, 'a'); if (ch != 'c') goto Fail; count++; longNum = L0 ((int *) chArray); if (longNum != 25442) goto Fail; printf ("Passed Special Conformance Test spc4.3.0.1\n"); return 0; Fail: printf ("Failed Special Conformance Test spc4.3.0.1: count = %d\n", count); return 0; } /*****************************************************************************/ static extended E1 (double x, float y) { return (x * y); } /*****************************************************************************/ static int F1 (float a, char ch) { return ((long) a) + ((long) ch); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.3.1.1.CC b/Tests/Spec.Conform/SPC4.3.1.1.CC new file mode 100755 index 0000000..69835de --- /dev/null +++ b/Tests/Spec.Conform/SPC4.3.1.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.3.1.1: Ensure default storage class for */ /* functions declared at the head of a */ /* block is extern */ /* */ /* Other files needed: spc4311.cc - separately compiled file containing */ /* functions called in this file */ /* spc4311.exec - EXEC file which separately compiles */ /* links and runs the files comprising */ /* this test */ /* */ main () { int I1 (char ch); double D1 (float f); char c; float f; c = I1 ('z'); if (c != 'Z') goto Fail; f = D1 (8.9); if (f != 8.0) goto Fail; printf ("Passed Special Conformance Test 4.3.1.1\n"); return; Fail: printf ("Failed Special Conformance Test 4.3.1.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.4.1.1.CC b/Tests/Spec.Conform/SPC4.4.1.1.CC new file mode 100755 index 0000000..036e3e7 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.4.1.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.4.1.1: Verification of ability to omit either */ /* type specifier or storage class in */ /* declarations, and both in function */ /* definitions */ /* */ /* Other files needed: spc4411.exec - separately compiles, links, and */ /* executes the files spc4.4.1.1.cc and */ /* spc4411.1.cc */ /* */ static x; /* type of x is int */ float y; /* storage class of y is extern */ static F1 (); /* non-prototyped form: returns int */ double G1 (); /* also non-prototyped form: storage */ /* class is extern */ main () { x = 0x7f << 2; /* if type is not int, error would be */ if (x != 0x1FC) /* flagged */ goto Fail1; y = 8.7; y = G1 (x); if (y != 508.0) goto Fail2; x = F1 (3, 4); if (x != 7) goto Fail; printf ("Passed Special Conformance Test 4.4.1.1\n"); return; Fail: printf ("Failed Special Conformance Test 4.4.1.1\n"); return; Fail1: printf ("extern int x not set correctly: x = %d\n", x); goto Fail; Fail2: printf ("extern double function G1 returns incorrect value: y = %f\n", y); goto Fail; Fail3: printf ("static int function F1 returns incorrect value: x = %d\n", x); goto Fail; } /******************************************************************************/ F1 (x, y) int x; int y; { return x + y; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.5.2.1.CC b/Tests/Spec.Conform/SPC4.5.2.1.CC new file mode 100755 index 0000000..edf1a91 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.5.2.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.5.2.1: Verification of pointer declarators for */ /* external data */ /* */ /* Other files needed: spc4521.exec - EXEC file which separately compiles, */ /* links, and executes test 4.5.2.1 */ /* spc4521.h - header file containing extern references*/ /* spc4521.1.cc - other source file comprising the test */ #include "spc4521.h" main () { extern void F1 (void); F1 (); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.5.3.1.CC b/Tests/Spec.Conform/SPC4.5.3.1.CC new file mode 100755 index 0000000..04ca147 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.5.3.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.5.3.1: Verfication of global array declarations */ /* */ /* Other files needed: spc4531.exec - Separately compiles, links, and */ /* executes the files needed to run test */ /* spc4531.1.cc - Extern function which tests the arrays */ /* spc4531.h - Header file declaring global arrays */ int i1 [50], i3 [3] [5] [8]; /* all basic types */ long L1 [9], L2 [2] [6]; unsigned int ui3 [4] [5] [1], ui1 [7]; unsigned long ul2 [5] [3], ul1 [1]; comp c1 [3], c2 [2] [3]; char ch2 [6] [5], ch1 [10]; float f1 [3], f4 [2] [3] [1] [4]; double d2 [2] [4], d1 [8]; extended e1 [9], e2 [7] [3]; /* conglomerate types */ struct s { int a; float f; }; struct s s1 [10], s2 [5] [4]; enum colors { red, black, green }; enum colors C3 [2] [1] [3], C1 [6]; union longOrShort { int first; long second; }; union longOrShort u2 [3] [3], u1 [12]; main () { extern int TestArray (void); if ( TestArray() ) printf ("Passed Special Conformance Test 4.5.3.1\n"); else printf ("Failed Special Conformance Test 4.5.3.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.5.3.2.CC b/Tests/Spec.Conform/SPC4.5.3.2.CC new file mode 100755 index 0000000..717290c --- /dev/null +++ b/Tests/Spec.Conform/SPC4.5.3.2.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.5.3.2: Verfication of external array */ /* declarations: arrays of pointers */ /* */ /* Other files needed: spc4532.1.cc - separately compiled file */ /* containing test of arrays */ /* spc4532.h - header file containing extern */ /* declarations needed by second file */ /* spc4532.exec - EXEC file which separately compiles*/ /* links and executes test 4.5.3.0.2 */ int *i1 [50]; /* all basic types */ long *L1 [9]; comp *c1 [3]; char *ch1 [10]; float *f1 [3]; double *d1 [8]; extended *e1 [9]; unsigned int *ui3 [4] [5] [1], *ui1 [7]; unsigned long *ul2 [5] [3], *ul1 [1]; /* conglomerate types */ struct s { int a; float f; }; struct s *s1 [10], S; enum colors { red, black, green }; enum colors *en [6], C; union longOrShort { int first; long second; }; union longOrShort *u1 [12], U; main () { extern int TestEm (void); if (TestEm) printf ("Passed Special Conformance Test 4.5.3.2\n"); else printf ("Failed Special Conformance Test 4.5.3.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.6.3.1.CC b/Tests/Spec.Conform/SPC4.6.3.1.CC new file mode 100755 index 0000000..c793aa1 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.6.3.1.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.6.3.1: Verification of pointer initializers; */ /* setting to name of a function. */ /* */ /* Other files needed: spc4631.1.cc - File containing the external functions */ /* called by main */ /* spc4631.exec - EXEC file which separately compiles, */ /* links, and executes files to run test */ #include /* static and extern pointer variables can use only constant expressions */ struct S { int a; float b; }; union U { int i; long L; }; static int I1 (void); /* declare static functions */ static char Ch1 (void); static long L1 (void); static comp C1 (void); static float F1 (void); static double D1 (void); static extended E1 (void); static unsigned int UI1 (void); static unsigned long UL1 (void); static struct S S1 (void); static union U U1 (void); extern int I2 (void); /* declare extern functions */ extern char Ch2 (void); extern long L2 (void); extern comp C2 (void); extern float F2 (void); extern double D2 (void); extern extended E2 (void); extern unsigned int UI2 (void); extern unsigned long UL2 (void); extern struct S S2 (void); extern union U U2 (void); /* initialize variables to name of function */ static int (*i1Ptr) (void) = I1; static char (*ch1Ptr) (void) = Ch1; static long (*L1Ptr) (void) = L1; static comp (*c1Ptr) (void) = C1; static float (*f1Ptr) (void) = F1; static double (*d1Ptr) (void) = D1; static extended (*e1Ptr) (void) = E1; static unsigned int (*ui1Ptr) (void) = UI1; static unsigned long (*uL1Ptr) (void) = UL1; static struct S (*struct1Ptr) (void) = S1; static union U (*union1Ptr ) (void) = U1; int (*i2Ptr) (void) = I2; char (*ch2Ptr) (void) = Ch2; long (*L2Ptr) (void) = L2; comp (*c2Ptr) (void) = C2; float (*f2Ptr) (void) = F2; double (*d2Ptr) (void) = D2; extended (*e2Ptr) (void) = E2; unsigned int (*ui2Ptr) (void) = UI2; unsigned long (*uL2Ptr) (void) = UL2; struct S (*struct2Ptr) (void) = S2; union U (*union2Ptr ) (void) = U2; /* Other external variables */ struct S extStruct1 = { 2, 5.7 }; struct S extStruct2 = { 18, 0.3 }; union U extUnion1 = { 32767 }; union U extUnion2 = { 29 }; /* Function dispatchers */ /*****************************************************************************/ int DispI (int (*func) (void)) { return (*func) (); } /*****************************************************************************/ char DispCh (char (*func) (void)) { return (*func) (); } /*****************************************************************************/ long DispL (long (*func) (void)) { return (*func) (); } /*****************************************************************************/ comp DispC (comp (*func) (void)) { return (*func) (); } /*****************************************************************************/ float DispF (float (*func) (void)) { return (*func) (); } /*****************************************************************************/ double DispD (double (*func) (void)) { return (*func) (); } /*****************************************************************************/ extended DispE (extended (*func) (void)) { return (*func) (); } /*****************************************************************************/ unsigned int DispUI (unsigned int (*func) (void)) { return (*func) (); } /*****************************************************************************/ unsigned long DispUL (unsigned long (*func) (void)) { return (*func) (); } /*****************************************************************************/ struct S DispS (struct S (*func) (void)) { return (*func) (); } /*****************************************************************************/ union U DispU (union U (*func) (void)) { return (*func) (); } /*****************************************************************************/ main () { extern int ExternTest (void); int count = 0; int i; char ch; long LL; comp c; float f; double d; extended e; unsigned int unInt; unsigned long unLong; struct S svar; union U uvar; count++; i = DispI (i1Ptr); if (i != 1) goto Fail; count++; ch = DispCh (ch1Ptr); if (ch != 'a') goto Fail; count++; LL = DispL (L1Ptr); if (LL != 0x65535) goto Fail; count++; c = DispC (c1Ptr); if (c != 4294967295ul) goto Fail; count++; f = DispF (f1Ptr); if (f != 3.5) goto Fail; count++; d = DispD (d1Ptr); if (d != 108.0e20) goto Fail; count++; e = DispE (e1Ptr); if (e != 0.123E-300) goto Fail; count++; unInt = DispUI (ui1Ptr); if (unInt != 65534) goto Fail; count++; unLong = DispUL (uL1Ptr); if (unLong != 0x7F) goto Fail; count++; svar = DispS (struct1Ptr); if ((svar.a != 2) || (fabs (svar.b - 5.7) > 0.0001)) goto Fail; count++; uvar = DispU (union1Ptr); if (uvar.i != 32767) goto Fail; count++; if ( ExternTest () ) goto Fail; printf ("Passed Special Conformance Test 4.6.3.1\n"); return 0; Fail: printf ("Failed Special Conformance Test 4.6.3.1: count = %d\n", count); return 0; } /****************************************************************************/ static int I1 (void) { return 1; } /****************************************************************************/ static char Ch1 (void) { return 'a'; } /****************************************************************************/ static long L1 (void) { return 0x65535; } /****************************************************************************/ static comp C1 (void) { return 4294967295ul; } /****************************************************************************/ static float F1 (void) { return 3.5; } /****************************************************************************/ static double D1 (void) { return 108.0E20; } /****************************************************************************/ static extended E1 (void) { return .123e-300; } /****************************************************************************/ static unsigned int UI1 (void) { return 65534; } /****************************************************************************/ static unsigned long UL1 (void) { return 0x7f; } /****************************************************************************/ static struct S S1 (void) { return extStruct1; } /****************************************************************************/ static union U U1 (void) { return extUnion1; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.6.3.2.CC b/Tests/Spec.Conform/SPC4.6.3.2.CC new file mode 100755 index 0000000..fe0bc9a --- /dev/null +++ b/Tests/Spec.Conform/SPC4.6.3.2.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.6.3.2: Verification of static & extern pointer */ /* initializers: setting pointer to name */ /* of a static or extern array. */ /* */ /* Other files needed: spc4632.1.cc - separately compiled file which accesses */ /* external arrays initialized here */ /* spc4632.exec - EXEC file which separately compiles the */ /* two source files and then links and */ /* executes them to perform the test */ #include /* static and extern pointer variables can use only constant expressions */ struct S { int a; float b; }; union U { int i; long L; }; /* Declare and initialize static arrays */ static int I1 [2] = { 1, 2 }; static char Ch1 [2] = { 'a', 'b' }; static long L1 [2] = { 32778, 32889 }; static comp C1 [2] = { 65535, 65530 }; static float F1 [2] = { 1.1, 1.2, }; static double D1 [2] = { 2.2, 2.3, }; static extended E1 [2] = { 3.0, 3.3, }; static unsigned int UI1 [2] = { 0xFFFF, 0x0011 }; static unsigned long UL1 [2] = { 0xFFFFFFFF, 0x7FFFFFFF }; static struct S S1 [2] = { { 4, 8.0 }, { 10, 15.0 } }; static union U U1 [2] = { 3 }; /* Declare and initialize extern arrays */ int I2 [2] = { 8, 9 }; char Ch2 [2] = { 'x', 'y' }; long L2 [2] = { 17, 23 }; comp C2 [2] = { 45000, 500000 }; float F2 [2] = { 123.456, 6.0e7 }; double D2 [2] = { 0.5e10, 3.27 }; extended E2 [2] = { 7.4, 9.9 }; unsigned int UI2 [2] = { 10, 11 }; unsigned long UL2 [2] = { 4, 4 }; struct S S2 [2] = { 888, 8.88, 999, 9.99 }; union U U2 [2] = { 7777 }; /* initialize pointer variables to names of static and extern arrays */ static int (*i1Ptr) = I1; static char (*ch1Ptr) = Ch1; static long (*L1Ptr) = L1; static comp (*c1Ptr) = C1; static float (*f1Ptr) = F1; static double (*d1Ptr) = D1; static extended (*e1Ptr) = E1; static unsigned int (*ui1Ptr) = UI1; static unsigned long (*uL1Ptr) = UL1; static struct S (*struct1Ptr) = S1; static union U (*union1Ptr ) = U1; int (*i2Ptr) = I2; char (*ch2Ptr) = Ch2; long (*L2Ptr) = L2; comp (*c2Ptr) = C2; float (*f2Ptr) = F2; double (*d2Ptr) = D2; extended (*e2Ptr) = E2; unsigned int (*ui2Ptr) = UI2; unsigned long (*uL2Ptr) = UL2; struct S (*struct2Ptr) = S2; union U (*union2Ptr ) = U2; main () { int count = 0; extern int ExternTest (void); count++; if ((*(i1Ptr) != 1) || (*(i1Ptr + 1) != 2)) goto Fail; count++; if ((*(ch1Ptr) != 'a') || (*(ch1Ptr + 1) != 'b')) goto Fail; count++; if ((*(L1Ptr) != 32778) || (*(L1Ptr + 1) != 32889)) goto Fail; count++; if ((*(c1Ptr) != 65535) || (*(c1Ptr + 1) != 65530)) goto Fail; count++; if ((fabs (*(f1Ptr) - 1.1) > 0.0001) || (fabs (*(f1Ptr + 1) - 1.2) > 0.0001)) goto Fail; count++; if ((fabs (*(d1Ptr) - 2.2) > 0.0001) || (fabs (*(d1Ptr + 1) - 2.3) > 0.0001)) goto Fail; count++; if ((fabs (*(e1Ptr) - 3.0) > 0.0001) || (fabs (*(e1Ptr + 1) - 3.3) > 0.0001)) goto Fail; count++; if ((*(ui1Ptr) != 0xFFFF) || (*(ui1Ptr + 1) != 0x0011)) goto Fail; count++; if ((*(uL1Ptr) != 0xffffffff) || (*(uL1Ptr + 1) != 0x7fffffff)) goto Fail; count++; if ((struct1Ptr->a != 4) || ((struct1Ptr + 1)->a != 10)) goto Fail; count++; if ((fabs (struct1Ptr->b - 8.0) > 0.0001) || (fabs ((struct1Ptr + 1)->b - 15.0) > 0.0001)) goto Fail; count++; if ((union1Ptr->i != 3) || ((union1Ptr + 1)->i != 0)) goto Fail; if ( ExternTest () ) goto Fail2; printf ("Passed Special Conformance Test 4.6.3.2\n"); return; Fail: printf ("count = %d\n", count); Fail2: printf ("Failed Special Conformance Test 4.6.3.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.6.3.3.CC b/Tests/Spec.Conform/SPC4.6.3.3.CC new file mode 100755 index 0000000..ef7c5aa --- /dev/null +++ b/Tests/Spec.Conform/SPC4.6.3.3.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.6.3.3: Verification of static & extern pointer */ /* initializers: setting pointer to name */ /* of a static or extern variable. */ /* */ /* Other files needed: spc4633.1.cc - separately compiled file which accesses */ /* external arrays initialized here */ /* spc4633.exec - EXEC file which separately compiles the */ /* two source files and then links and */ /* executes them to perform the test */ #include /* static and extern pointer variables can use only constant expressions */ struct S { int a; float b; }; union U { int i; long L; }; /* Declare and initialize static variables */ static int I1 = { 1, }; static char Ch1 = { 'a', }; static long L1 = { 32778, }; static comp C1 = { 65535, }; static float F1 = { 1.1, }; static double D1 = { 2.2, }; static extended E1 = { 3.0, }; static unsigned int UI1 = { 0xFFFF, }; static unsigned long UL1 = { 0xFFFFFFFF, }; static struct S S1 = { 4, 8.0 }; static union U U1 = { 3 }; /* Declare and initialize extern variables */ int I2 = { 8, }; char Ch2 = { 'x', }; long L2 = { 17, }; comp C2 = { 45000, }; float F2 = { 123.456, }; double D2 = { 0.5e10, }; extended E2 = { 7.4, }; unsigned int UI2 = { 10, }; unsigned long UL2 = { 4, }; struct S S2 = { 888, 8.88, }; union U U2 = { 7777 }; /* initialize pointer variables to names of static and extern variables */ static int (*i1Ptr) = &I1; static char (*ch1Ptr) = &Ch1; static long (*L1Ptr) = &L1; static comp (*c1Ptr) = &C1; static float (*f1Ptr) = &F1; static double (*d1Ptr) = &D1; static extended (*e1Ptr) = &E1; static unsigned int (*ui1Ptr) = &UI1; static unsigned long (*uL1Ptr) = &UL1; static struct S (*struct1Ptr) = &S1; static union U (*union1Ptr ) = &U1; int (*i2Ptr) = &I2; char (*ch2Ptr) = &Ch2; long (*L2Ptr) = &L2; comp (*c2Ptr) = &C2; float (*f2Ptr) = &F2; double (*d2Ptr) = &D2; extended (*e2Ptr) = &E2; unsigned int (*ui2Ptr) = &UI2; unsigned long (*uL2Ptr) = &UL2; struct S (*struct2Ptr) = &S2; union U (*union2Ptr ) = &U2; main () { int count = 0; extern int ExternTest (void); count++; if (*(i1Ptr) != 1) goto Fail; count++; if (*(ch1Ptr) != 'a') goto Fail; count++; if (*(L1Ptr) != 32778) goto Fail; count++; if (*(c1Ptr) != 65535) goto Fail; count++; if (fabs (*(f1Ptr) - 1.1) > 0.0001) goto Fail; count++; if (fabs (*(d1Ptr) - 2.2) > 0.0001) goto Fail; count++; if (fabs (*(e1Ptr) - 3.0) > 0.0001) goto Fail; count++; if (*(ui1Ptr) != 0xFFFF) goto Fail; count++; if (*(uL1Ptr) != 0xffffffff) goto Fail; count++; if ((struct1Ptr->a != 4) || (fabs (struct1Ptr->b - 8.0) > 0.0001)) goto Fail; count++; if (union1Ptr->i != 3) goto Fail; if ( ExternTest () ) goto Fail; printf ("Passed Special Conformance Test 4.6.3.3\n"); return; Fail: printf ("count = %d\n", count); printf ("Failed Special Conformance Test 4.6.3.3\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.6.3.4.CC b/Tests/Spec.Conform/SPC4.6.3.4.CC new file mode 100755 index 0000000..4ed0665 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.6.3.4.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.6.3.4: Verification of static & extern pointer */ /* initializers: setting pointer to element*/ /* of a static or extern array. */ /* */ /* Other files needed: spc4634.1.cc - separately compiled file which accesses */ /* external addresses initialized here */ /* spc4634.exec - EXEC file which separately compiles the */ /* two source files and then links and */ /* executes them to perform the test */ #include /* static and extern pointer variables can use only constant expressions */ struct S { int a; float b; }; union U { int i; long L; }; /* Declare and initialize static arrays */ static int I1 [2] = { 1, 2 }; static char Ch1 [2] = { 'a', 'b' }; static long L1 [2] = { 32778, }; static comp C1 [2] = { 65535, 978 }; static float F1 [2] = { 1.1, 3.4 }; static double D1 [2] = { 2.2, 3.7 }; static extended E1 [2] = { 3.0, 4.0 }; static unsigned int UI1 [2] = { 0xFFFF, 0xabcd }; static unsigned long UL1 [2] = { 0xFFFFFFFF, 0xef010101 }; static struct S S1 [2] = { 4, 8.0, 10, 20.5 }; static union U U1 [2] = { 3, 32767 }; /* Declare and initialize extern variables */ int I2 [2] = { 8, 9 }; char Ch2 [2] = { 'x', 'z' }; long L2 [2] = { 17, 27 }; comp C2 [2] = { 45000, 100000 }; float F2 [2] = { 123.456, 12.3456 }; double D2 [2] = { 0.5e10, 0.65 }; extended E2 [2] = { 7.4, 4.7 }; unsigned int UI2 [2] = { 10, 20 }; unsigned long UL2 [2] = { 4, 88 }; struct S S2 [2] = { 888, 8.88, 999, 9.99 }; union U U2 [2] = { 7777 }; /* Initialize pointer variables to array addresses */ static int (*i1Ptr) = &I1 [1]; static char (*ch1Ptr) = &Ch1 [1]; static long (*L1Ptr) = &L1 [1]; static comp (*c1Ptr) = &C1 [1]; static float (*f1Ptr) = &F1 [1]; static double (*d1Ptr) = &D1 [1]; static extended (*e1Ptr) = &E1 [1]; static unsigned int (*ui1Ptr) = &UI1 [1]; static unsigned long (*uL1Ptr) = &UL1 [1]; static struct S (*struct1Ptr) = &S1 [1]; static union U (*union1Ptr ) = &U1 [1]; int (*i2Ptr) = &I2 [1]; char (*ch2Ptr) = &Ch2 [1]; long (*L2Ptr) = &L2 [1]; comp (*c2Ptr) = &C2 [1]; float (*f2Ptr) = &F2 [1]; double (*d2Ptr) = &D2 [1]; extended (*e2Ptr) = &E2 [1]; unsigned int (*ui2Ptr) = &UI2 [1]; unsigned long (*uL2Ptr) = &UL2 [1]; struct S (*struct2Ptr) = &S2 [1]; union U (*union2Ptr ) = &U2 [1]; main () { int count = 0; extern int ExternTest (void); count++; if (*(i1Ptr) != 2) goto Fail; count++; if (*(ch1Ptr) != 'b') goto Fail; count++; if (*(L1Ptr) != 0) goto Fail; count++; if (*c1Ptr != 978) goto Fail; count++; if (fabs (*(f1Ptr) - 3.4) > 0.0001) goto Fail; count++; if (fabs (*(d1Ptr) - 3.7) > 0.0001) goto Fail; count++; if (fabs (*(e1Ptr) - 4.0) > 0.0001) goto Fail; count++; if (*(ui1Ptr) != 0xABCD) goto Fail; count++; if (*(uL1Ptr) != 0xEF010101) goto Fail; count++; if ((struct1Ptr->a != 10) || (fabs (struct1Ptr->b - 20.5) > 0.0001)) goto Fail; count++; if (union1Ptr->i != 32767) goto Fail; count++; if ( ExternTest () ) goto Fail; printf ("Passed Special Conformance Test 4.6.3.4\n"); return 0; Fail: printf ("count = %d\n", count); printf ("Failed Special Conformance Test 4.6.3.4\n"); return 0; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.6.3.5.CC b/Tests/Spec.Conform/SPC4.6.3.5.CC new file mode 100755 index 0000000..222a29b --- /dev/null +++ b/Tests/Spec.Conform/SPC4.6.3.5.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.6.3.5: Verification of pointer initialization: */ /* setting pointer to integer constant */ /* */ /* Tester needs to enter one character from the keyboard and then check that */ /* the key echoed is the same key. */ /* */ main () { static char *keyBoard = (char *) 0xC000ul, *strobe = (char *) 0xC010ul, ch; *keyBoard = 0; printf ("Please type one character\n"); while (!(*keyBoard & 0x0080)) ; *strobe = 1; ch = *keyBoard; printf ("The character typed is: %c\n", ch); return; Fail: printf ("Failed Special Conformance Test 4.6.3.5\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4.6.3.6.CC b/Tests/Spec.Conform/SPC4.6.3.6.CC new file mode 100755 index 0000000..b6a1fa1 --- /dev/null +++ b/Tests/Spec.Conform/SPC4.6.3.6.CC @@ -0,0 +1 @@ +/* Special Conformance Test 4.6.3.6: Verification of static & extern pointer */ /* initializers: setting pointer to name */ /* of a static or extern array + constant */ /* */ /* Other files needed: spc4636.1.cc - separately compiled file which accesses */ /* external arrays initialized here */ /* spc4636.exec - EXEC file which separately compiles the */ /* two source files and then links and */ /* executes them to perform the test */ #include /* static and extern pointer variables can use only constant expressions */ struct S { int a; float b; }; union U { int i; long L; }; /* Declare and initialize static arrays */ static int I1 [2] = { 1, 2 }; static char Ch1 [2] = { 'a', 'b' }; static long L1 [2] = { 32778, 32889 }; static comp C1 [2] = { 65535, 65530 }; static float F1 [2] = { 1.1, 1.2 }; static double D1 [2] = { 2.2, 2.3 }; static extended E1 [2] = { 3.0, 3.3 }; static unsigned int UI1 [2] = { 0xFFFF, 0x0011 }; static unsigned long UL1 [2] = { 0xFFFFFFFF, 0x7FFFFFFF }; static struct S S1 [2] = { { 4, 8.0 }, { 10, 15.0 } }; static union U U1 [2] = { 3 }; /* Declare and initialize extern arrays */ int I2 [2] = { 8, 9 }; char Ch2 [2] = { 'x', 'y' }; long L2 [2] = { 17, 23 }; comp C2 [2] = { 45000, 500000 }; float F2 [2] = { 123.456, 6.0e7 }; double D2 [2] = { 0.5e10, 3.27 }; extended E2 [2] = { 7.4, 9.9 }; unsigned int UI2 [2] = { 10, 11 }; unsigned long UL2 [2] = { 4, 4 }; struct S S2 [2] = { 888, 8.88, 999, 9.99 }; union U U2 [2] = { 7777 }; /* Initialize pointer variables to (names of static and extern arrays) + 1 */ static int (*i1Ptr) = I1 + 1; static char (*ch1Ptr) = Ch1 + 1; static long (*L1Ptr) = L1 + 1; static comp (*c1Ptr) = C1 + 1; static float (*f1Ptr) = F1 + 1; static double (*d1Ptr) = D1 + 1; static extended (*e1Ptr) = E1 + 1; static unsigned int (*ui1Ptr) = UI1 + 1; static unsigned long (*uL1Ptr) = UL1 + 1; static struct S (*struct1Ptr) = S1 + 1; static union U (*union1Ptr ) = U1 + 1; int (*i2Ptr) = I2 + 1; char (*ch2Ptr) = Ch2 + 1; long (*L2Ptr) = L2 + 1; comp (*c2Ptr) = C2 + 1; float (*f2Ptr) = F2 + 1; double (*d2Ptr) = D2 + 1; extended (*e2Ptr) = E2 + 1; unsigned int (*ui2Ptr) = UI2 + 1; unsigned long (*uL2Ptr) = UL2 + 1; struct S (*struct2Ptr) = S2 + 1; union U (*union2Ptr ) = U2 + 1; main () { int count = 0; extern int ExternTest (void); count++; if (*(i1Ptr) != 2) goto Fail; count++; if (*(ch1Ptr) != 'b') goto Fail; count++; if (*(L1Ptr) != 32889) goto Fail; /* count++; if (*(c1Ptr) != 65530) goto Fail; */ count++; if (fabs (*(f1Ptr) - 1.2) > 0.0001) goto Fail; count++; if (fabs (*(d1Ptr) - 2.3) > 0.0001) goto Fail; count++; if (fabs (*(e1Ptr) - 3.3) > 0.0001) goto Fail; count++; if (*(ui1Ptr) != 0x0011) goto Fail; count++; if (*(uL1Ptr) != 0x7fffffff) goto Fail; count++; if ((struct1Ptr->a != 10) || (fabs (struct1Ptr->b - 15.0) > 0.0001)) goto Fail; count++; if (union1Ptr->i != 0) goto Fail; if ( ExternTest () ) goto Fail2; printf ("Passed Special Conformance Test 4.6.3.6\n"); return; Fail: printf ("count = %d\n", count); Fail2: printf ("Failed Special Conformance Test 4.6.3.6\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4301.1.CC b/Tests/Spec.Conform/SPC4301.1.CC new file mode 100755 index 0000000..54fd4ad --- /dev/null +++ b/Tests/Spec.Conform/SPC4301.1.CC @@ -0,0 +1 @@ +/* The first separately compiled file for Special Conformance Test 4.3.0.1 */ /* Function L0 and variables longNum and i are accessed by main. */ long longNum; int i; long L0 (int *j) { if (i != 4) return 0; else return (long) (*j); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4301.2.CC b/Tests/Spec.Conform/SPC4301.2.CC new file mode 100755 index 0000000..bbe6952 --- /dev/null +++ b/Tests/Spec.Conform/SPC4301.2.CC @@ -0,0 +1 @@ +/* The second separately compiled file for Special Conformance Test 4.3.0.1 */ /* Function ChangeChar and variable real are accessed by main. */ float real; void ChangeChar (char *ch) { *ch += 1; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4301.EXEC b/Tests/Spec.Conform/SPC4301.EXEC new file mode 100755 index 0000000..0c28dd6 --- /dev/null +++ b/Tests/Spec.Conform/SPC4301.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.3.0.1 * set exit on echo compile spc4.3.0.1.cc compile spc4.3.0.1.cc keep=3/out if {status} == 0 echo compile spc4301.1.cc compile spc4301.1.cc keep=3/out1 if {status} == 0 echo compile spc4301.2.cc compile spc4301.2.cc keep=3/out2 if {status} == 0 link +s 3/out 3/out1 3/out2 keep=3/out >3/spc4301.symt if {status} == 0 3/out else echo "Unable to link Special Conformance Test 4.3.0.1" end else echo "Unable to compile file spc4301.2.cc" end else echo "Unable to compile file spc4301.1.cc" end else echo "Unable to compile file spc4.3.0.1.cc" end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4301.H b/Tests/Spec.Conform/SPC4301.H new file mode 100755 index 0000000..2fdbad2 --- /dev/null +++ b/Tests/Spec.Conform/SPC4301.H @@ -0,0 +1 @@ +/* Header file for Special Conformance Test 4.3.0.1 */ static int F1 (float a, char ch); static char chArray [] = { "abcd" }; extern void ChangeChar (char *ch); extern float real; extern long longNum; \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4311.1.CC b/Tests/Spec.Conform/SPC4311.1.CC new file mode 100755 index 0000000..98bb874 --- /dev/null +++ b/Tests/Spec.Conform/SPC4311.1.CC @@ -0,0 +1 @@ +/* Separately compiled file containing functions called from main program in */ /* the file spc4.3.1.1.cc. */ #include int I1 (char ch) { if (islower (ch)) return toupper (ch); } /*****************************************************************************/ #include double D1 (float f) { return floor (f); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4311.EXEC b/Tests/Spec.Conform/SPC4311.EXEC new file mode 100755 index 0000000..163766a --- /dev/null +++ b/Tests/Spec.Conform/SPC4311.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.3.1.1 * unset exit set echo on compile spc4.3.1.1.cc keep=3/spc4311.mn set errNo {status} if {errNo} == 0 compile spc4311.1.cc keep=3/spc4311.1 set errNo {status} if {errNo} == 0 link 3/spc4311.mn 3/spc4311.1 keep=3/spc4311 set errNo {status} if {errNo} == 0 3/spc4311 else echo Unable to link Special Conformance Test 4.3.1.1 end else echo Unable to compile file spc4311.1.cc end else echo Unable to compile file spc4.3.1.1.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4411.1.CC b/Tests/Spec.Conform/SPC4411.1.CC new file mode 100755 index 0000000..4764a15 --- /dev/null +++ b/Tests/Spec.Conform/SPC4411.1.CC @@ -0,0 +1 @@ +/* Other file needed to run Special Conformance Test 4.4.1.1 */ #include extern float y; double G1 (x) int x; { if ( (fabs (y - 8.7)) > 0.0001 ) return 0.0; else return (double) x; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4521.1.CC b/Tests/Spec.Conform/SPC4521.1.CC new file mode 100755 index 0000000..c571c89 --- /dev/null +++ b/Tests/Spec.Conform/SPC4521.1.CC @@ -0,0 +1 @@ +/* Separately compiled file needed to run Special Conformance Test 4.5.2.1 */ #include #include /* Global data */ int *intPtr, i; /* pointers to all the basic types */ long *longPtr, L; unsigned int *uintPtr, ui; unsigned long *ulongPtr, ulong; comp *compPtr, cmp; char *charPtr, ch; float *floatPtr, fl; double *doublePtr, dbl; extended *extPtr, ext; /* pointers to conglomerate types */ struct s { int a; long L; } *structPtr, s; enum colors { red, black, green } *colorPtr, color; union longOrShort { int first; long second; } *unionPtr, un; void F1 (void) { int count = 0; count += 1; intPtr = &i; i = 3; if (*intPtr != 3) goto Fail; count += 1; longPtr = &L; L = INT_MAX + 2L; if (*longPtr != 32769) goto Fail; count += 1; uintPtr = &ui; ui = UINT_MAX; if (*uintPtr != 65535u) goto Fail; count += 1; ulongPtr = &ulong; ulong = ULONG_MAX; if (*ulongPtr != 4294967295ul) goto Fail; count += 1; compPtr = &cmp; cmp = ulong + 4; if (*compPtr != ULONG_MAX + 4) goto Fail; count += 1; charPtr = &ch; ch = 'A'; if (*charPtr != 'A') goto Fail; count += 1; floatPtr = &fl; fl = 123.456; if ( (fabs (*floatPtr - 123.456)) > 0.0001 ) goto Fail; count += 1; doublePtr = &dbl; dbl = 0.0; if (fabs (*doublePtr - 0.0) > 0.00001) goto Fail; count += 1; extPtr = &ext; ext = 12.3e20; if ( (fabs (*extPtr - 123.0E19)) > 0.0001 ) goto Fail; count += 1; structPtr = &s; s.a = INT_MAX; s.L = LONG_MAX; if ((structPtr->L != 2147483647l) || (structPtr->a != 32767)) goto Fail; count += 1; intPtr = &(s.a); if (*intPtr != 32767) goto Fail; count += 1; longPtr = &(s.L); if (*longPtr != LONG_MAX) goto Fail; count += 1; colorPtr = &color; color = black; if (*colorPtr != black) goto Fail; count += 1; unionPtr = &un; un.first = 12; if (unionPtr->first != 12) goto Fail; count += 1; un.second = 2147483646; if (unionPtr->second != 2147483646) goto Fail; printf ("Passed Special Conformance Test 4.5.2.1\n"); return; Fail: printf ("Failed Special Conformance Test 4.5.2.1\n"); printf ("count = %d\n", count); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4521.EXEC b/Tests/Spec.Conform/SPC4521.EXEC new file mode 100755 index 0000000..5fec407 --- /dev/null +++ b/Tests/Spec.Conform/SPC4521.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.5.2.1 * unset exit echo compile spc4.5.2.1.cc compile spc4.5.2.1.cc keep=3/out if {status} == 0 echo compile spc4521.1.cc compile spc4521.1.cc keep=3/out1 if {status} == 0 echo link spc4.5.2.1.cc link 3/out 3/out1 keep=3/out if {status} == 0 3/out else echo Unable to link Special Conformance Test 4.5.2.1 end else echo Unable to compile file spc4521.1.cc end else echo Unable to compile file spc4.5.2.1.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4521.H b/Tests/Spec.Conform/SPC4521.H new file mode 100755 index 0000000..3243a8d --- /dev/null +++ b/Tests/Spec.Conform/SPC4521.H @@ -0,0 +1 @@ +/* Header file for Special Conformance Test 4.5.2.1 */ /* pointers to all the basic types */ extern int *intPtr, i; extern long *longPtr, L; extern unsigned int *uintPtr, ui; extern unsigned long *ulongPtr, ulong; extern comp *compPtr, cmp; extern char *charPtr, ch; extern float *floatPtr, fl; extern double *doublePtr, dbl; extern extended *extPtr, ext; /* pointers to conglomerate types */ extern struct s { int a; long L; } *structPtr, s; extern enum colors { red, black, green } *colorPtr, color; extern union longOrShort { int first; long second; } *unionPtr, un; \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4531.1.CC b/Tests/Spec.Conform/SPC4531.1.CC new file mode 100755 index 0000000..25cb985 --- /dev/null +++ b/Tests/Spec.Conform/SPC4531.1.CC @@ -0,0 +1 @@ +#include #include "spc4531.h" /****************************************************************************/ int TestArray ( void ) { int count = 0; int i, j, k, n; /* loop indices */ long L; /* l-values */ char ch; float f; double d; extended e; unsigned int ui; unsigned long ul; count += 1; for (i = 0; i < 50; i++) /* assign & check singly-dimensioned */ i1 [i] = i; /* integer array */ for (i = 49; i >= 0; i--) if (i1 [i] != i) goto Fail; count += 1; for (i = 0; i < 3; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* integer array */ for (k = 0; k < 8; k++) i3 [i] [j] [k] = k; for (i = 2; i >= 0; i--) for (j = 4; j >= 0; j--) for (k = 7; k >= 0; k--) if (i3 [i] [j] [k] != k) goto Fail; count += 1; for (ch = 'a', i = 0; i < 6; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* character arrays */ ch2 [i] [j] = ch++; for (ch = '~', n = 5; n >= 0; n--) for (k = 4; k >= 0; k--) if (ch2 [n] [k] != ch--) goto Fail; count += 1; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ ch1 [i] = (char) (i + 0x41); /* character arrays */ for (ch = 'J', i = 9; i >= 0; i--) if (ch1 [i] != ch--) goto Fail; count += 1; for (i = 8; i >= 0; i--) /* assign & check singly-dimensioned */ L1 [i] = 2147483647; /* long integer array */ for (i = 0; i < 9; i++) if (L1 [i] != 2147483647) goto Fail; count += 1; for (L = 2147483646, i = 0; i < 2; i++) /* assign & check multiply- */ for (j = 0; j < 6; j++) /* dimensioned long integer*/ L2 [i] [j] = L--; /* array */ for (L = 2147483634, i = 1; i >= 0; i--) for (j = 5; j >= 0; j--) if (L2 [i] [j] != ++L) goto Fail; count += 1; for (ui = 65534, i = 0; i < 7; i++) /* assign & check singly-dimensioned */ ui1 [i] = ui--; /* unsigned integer array */ for (ui = 65527, i = 6; i >= 0; i--) if (ui1 [i] != ++ui) goto Fail; count += 1; for (ui = 65534, i = 0; i < 4; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 5; j++) /* unsigned integer array */ for (k = 0; k < 1; k++) ui3 [i] [j] [k] = ui--; for (ui = 65514, i = 3, k = 0; i >= 0; i--) for (j = 4; j >= 0; j--) if (ui3 [i] [j] [k] != ++ui) goto Fail; count += 1; for (ul = 4294967279ul, i = 0; i < 5; i++) /* assign & check multiply- */ for (j = 0; j < 3; j++) /* dimensioned unsigned */ ul2 [i] [j] = ul++; /* long integer array */ for (ul = 4294967294ul, i = 4; i >= 0; i--) for (j = 2; j >= 0; j--) if (ul2 [i] [j] != --ul) goto Fail; count += 1; ul1 [0] = ul; /* assign & check singly-dimensioned */ if (ul1 [0] != 4294967279ul) /* unsigned long integer array */ goto Fail; count += 1; for (i = 0; i < 3; i++) /* assign & check singly-dimensioned */ c1 [i] = i; /* comp array */ for (j = 2; j >= 0; j--) if (c1 [j] != j) goto Fail; count += 1; for (i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* comp array */ c2 [i] [j] = 0; for (k = 1; k >= 0; k--) for (i = 2; i >= 0; i--) if (c2 [i] [j] != 0) goto Fail; count += 1; f1 [0] = f1 [1] = f1 [2] = 43.8; /* assign & check singly-dimensioned */ for (k = 0; k < 3; k++) /* float array */ if ( (fabs (f1 [k] - 43.8)) > 0.0001 ) goto Fail; for (f = 1.0, i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* float array */ for (k = 0; k < 1; k++) for (n = 0; n < 4; n++) f4 [i] [j] [k] [n] = f++; count += 1; for (f = 24.0, k = 0, i = 1; i >= 0; i--) for (j = 2; j >= 0; j--) for (n = 3; n >= 0; n--) if (f4 [i] [j] [k] [n] != f--) goto Fail; count += 1; for (i = 0; i < 2; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 4; j++) /* double array */ d2 [i] [j] = 0.00; for (d = 0, k = 1; k >= 0; k--) for (i = 3; i >= 0; i--) if (d2 [k] [i] != d) goto Fail; count += 1; for (d1 [0] = 5.6, i = 1; i < 8; i++) /* assign & check singly- */ d1 [i] = d1 [i-1] + 1.0; /* dimensioned double array */ for (d = 12.6, k = 7; k >= 0; k--) if ( (fabs (d1 [k] - d--)) > 0.0001 ) goto Fail; count += 1; for (e = 96e-75, i = 0; i < 7; i++) /* assign & check multiply-dimensioned */ for (j = 0; j < 3; j++) /* extended array */ e2 [i] [j] = e; for (i = 0; i < 7; i++) for (j = 0; j < 3; j++) if ( (fabs (e2 [i] [j] - 96.0e-75)) > 0.0001 ) goto Fail; count += 1; for (k = 8; k >= 0; k--) /* assign & check singly-dimensioned */ e1 [k] = 0; /* extended array */ for (e = 0.000, i = 0; i < 9; i++) if (e1 [i] != e) goto Fail; count += 1; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ { /* array of structures */ s1 [i].a = i; s1 [i].f = (float) i * 2.0; } for (f = 18.0, i = 9; i >= 0; i--) { if ((s1 [i].a != i) || (fabs (s1 [i].f - f) > 0.0001) ) goto Fail; f -= 2.0; } for (n = 32766, f = 29.8E10, i = 0; i < 5; i++) /* assign & check multipy- */ for (j = 0; j < 4; j++) /* dimensioned array of */ { /* structures */ s2 [i] [j].a = n--; s2 [i] [j].f = f; } count += 1; for (n = 32746, k = 4; k >= 0; k--) for (j = 3; j >= 0; j--) if ((s2 [k] [j].a != ++n) || (fabs (s2 [k] [j].f - f) > 0.0001) ) goto Fail; count += 1; for (i = 1, j = 0, k = 0; k < 3; k++) /* assign & check multiply- */ C3 [i] [j] [k] = red; /* dimensioned array of */ for (i = 0, k = 0; k < 3; k++) /* enumerations */ C3 [i] [j] [k] = green; for (k = 0; k < 3; k++) if (C3 [0] [0] [k] != green) goto Fail; for (k = 0; k < 3; k++) if (C3 [1] [0] [k] != red) goto Fail; count += 1; for (n = 5; n >= 0; n--) /* assign & check singly- */ C1 [n] = black; /* dimensioned array of */ for (k = 0; k < 6; k++) /* enumerations */ if (C1 [k] != 1) goto Fail; count += 1; for (i = 0; i < 3; i++) /* assign & check multiply- */ for (j = 0; j < 3; j++) /* dimensioned array of */ u2 [i] [j].first = j; /* unions */ for (n = 2; n >= 0; n--) if (u2 [n] [0].first != 0) goto Fail; count += 1; for (n = 2; n >= 0; n--) if (u2 [n] [1].first != 1) goto Fail; count += 1; for (n = 2; n >= 0; n--) if (u2 [n] [2].first != 2) goto Fail; count += 1; for (L = 2147483646, i = 0; i < 3; i++) for (j = 0; j < 3; j++) u2 [i] [j].second = L--; for (L = 2147483637, k = 2; k >= 0; k--) for (n = 2; n >= 0; n--) if (u2 [k] [n].second != ++L) goto Fail; count += 1; for (i = 0; i < 12; i++) /* assign & check singly-dimensioned */ u1 [i].first = i; /* array of unions */ for (k = 11; k >= 0; k--) if (u1 [k].first != k) goto Fail; count += 1; for (L = 32767, j = 0; j < 12; j++) u1 [j].second = L++; for (L = 32778, n = 11; n >= 0; n--) if (u1 [n].second != L--) goto Fail; return (1); Fail: printf ("count = %d\n", count); return (0); } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4531.EXEC b/Tests/Spec.Conform/SPC4531.EXEC new file mode 100755 index 0000000..4950602 --- /dev/null +++ b/Tests/Spec.Conform/SPC4531.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.5.3.1 * unset exit compile spc4.5.3.1.cc keep=3/spc4531 set errNo {status} if {errNo} == 0 compile spc4531.1.cc keep=3/spc4531.1 set errNo {status} if {errNo} == 0 link 3/spc4531 3/spc4531.1 keep=3/spc4531 set errNo {status} if {errNo} == 0 3/spc4531 else echo Unable to link Special Conformance Test 4.5.3.1 end else echo Unable to compile file spc4531.1.cc end else echo Unable to compile file spc4.5.3.1.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4531.H b/Tests/Spec.Conform/SPC4531.H new file mode 100755 index 0000000..83c299a --- /dev/null +++ b/Tests/Spec.Conform/SPC4531.H @@ -0,0 +1 @@ +/* External array declarations needed to run Special Conformance Test 4.5.3.1 */ extern int i1 [50], i3 [3] [5] [8]; /* all basic types */ extern long L1 [9], L2 [2] [6]; extern unsigned int ui3 [4] [5] [1], ui1 [7]; extern unsigned long ul2 [5] [3], ul1 [1]; extern comp c1 [3], c2 [2] [3]; extern char ch2 [6] [5], ch1 [10]; extern float f1 [3], f4 [2] [3] [1] [4]; extern double d2 [2] [4], d1 [8]; extern extended e1 [9], e2 [7] [3]; /* conglomerate types */ struct s { int a; float f; }; extern struct s s1 [10], s2 [5] [4]; enum colors { red, black, green }; extern enum colors C3 [2] [1] [3], C1 [6]; union longOrShort { int first; long second; }; extern union longOrShort u2 [3] [3], u1 [12]; \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4532.1.CC b/Tests/Spec.Conform/SPC4532.1.CC new file mode 100755 index 0000000..b6554c5 --- /dev/null +++ b/Tests/Spec.Conform/SPC4532.1.CC @@ -0,0 +1 @@ +/* Separately compiled file named spc4532.1.cc, needed to perform Special */ /* Conformance Test 4.5.3.2 */ #include "spc4532.h" int TestEm (void) { int count = 0; int i, j, k, n; /* loop indices */ char ch; long L; /* l-values */ float f; double d; extended e; unsigned int ui; unsigned long ul; comp ci; count += 1; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ ch1 [i] = &ch; /* array of pointers to character */ ch = 'z'; for (i = 9; i >= 0; i--) if (*(ch1 [i]) != 'z') goto Fail; count += 1; for (i = 0; i < 50; i++) /* assign & check singly-dimensioned */ i1 [i] = &n; /* array of pointers to int */ n = 32767; for (i = 49; i >= 0; i--) if (*(i1 [i]) != 32767) goto Fail; count += 1; for (i = 8; i >= 0; i--) /* assign & check singly-dimensioned */ L1 [i] = &L; /* array of pointers to long int */ L = 2147483647; for (i = 0; i < 9; i++) if (*(L1 [i]) != 2147483647) goto Fail; count += 1; for (i = 0; i < 7; i++) /* assign & check singly-dimensioned */ ui1 [i] = &ui; /* array of ptrs to unsigned int */ ui = 65535; for (i = 6; i >= 0; i--) if (*(ui1 [i]) != 65535) goto Fail; count += 1; ul1 [0] = &ul; /* assign & check singly-dimensioned */ ul = 4294967278ul; /* array of ptrs to long unsigned int*/ if (*(ul1 [0]) != 0xffffffff) goto Fail; count += 1; for (i = 0; i < 3; i++) /* assign & check singly-dimensioned */ c1 [i] = &ci; /* array of pointers to comp */ ci = 2147483647; for (j = 2; j >= 0; j--) if (*(c1 [j]) != 2147483647) goto Fail; count += 1; f1 [0] = f1 [1] = f1 [2] = &f; /* assign & check singly-dimensioned */ f = 32.8; /* array of pointers to float */ for (k = 0; k < 3; k++) if (*(f1 [k]) != 32.8) goto Fail; count += 1; for (i = 1; i < 8; i++) /* assign & check singly- */ d1 [i] = &d; /* dimensioned array of */ d = 123.0e50; /* pointers to double */ for (k = 7; k >= 0; k--) if (*(d1 [k]) != 0.123E53) goto Fail; count += 1; for (k = 8; k >= 0; k--) /* assign & check singly-dimensioned */ e1 [k] = &e; /* array of pointers to extended */ e = 0.0e-300; for (i = 0; i < 9; i++) if (*(e1 [i]) != 0) goto Fail; count += 1; for (i = 0; i < 10; i++) /* assign & check singly-dimensioned */ s1 [i] = &S; /* array of pointers to structures */ S.a = 7; S.f = 6.4; for (i = 9; i >= 0; i--) if ((s1 [i]->a != 7) || (s1 [i]->f != 6.4)) goto Fail; count += 1; for (n = 5; n >= 0; n--) /* assign & check singly-dimensioned */ en [n] = &C; /* array of pointers to enumerations*/ C = black; for (k = 0; k < 6; k++) if (*(en [k]) != 1) goto Fail; count += 1; for (i = 0; i < 12; i++) /* assign & check singly-dimensioned */ u1 [i] = &U; /* array of pointers to union */ U.first = -45; for (k = 11; k >= 0; k--) if (u1 [k]->first != -45) goto Fail; count += 1; U.second = 32770; for (n = 11; n >= 0; n--) if (u1 [n]->second != 32770) goto Fail; return 1; Fail: printf ("count = %d\n", count); return 0; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4532.EXEC b/Tests/Spec.Conform/SPC4532.EXEC new file mode 100755 index 0000000..8fd40f6 --- /dev/null +++ b/Tests/Spec.Conform/SPC4532.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.5.3.2 * unset exit compile spc4.5.3.2.cc keep=3/spc4532 set errNo {status} if {errNo} == 0 compile spc4532.1.cc keep=3/spc4532.1 set errNo {status} if {errNo} == 0 link 3/spc4532 3/spc4532.1 keep=3/spc4532 set errNo {status} if {errNo} == 0 3/spc4532 else echo Unable to link Special Conformance Test 4.5.3.2 end else echo Unable to compile file spc4532.1.cc end else echo Unable to compile file spc4.5.3.2.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4532.H b/Tests/Spec.Conform/SPC4532.H new file mode 100755 index 0000000..30242c2 --- /dev/null +++ b/Tests/Spec.Conform/SPC4532.H @@ -0,0 +1 @@ +/* Header file for Special Conformance Test 4.5.3.2 */ extern int *i1 [50]; /* all basic types */ extern long *L1 [9]; extern comp *c1 [3]; extern char *ch1 [10]; extern float *f1 [3]; extern double *d1 [8]; extern extended *e1 [9]; extern unsigned int *ui3 [4] [5] [1], *ui1 [7]; extern unsigned long *ul2 [5] [3], *ul1 [1]; /* conglomerate types */ struct s { int a; float f; }; extern struct s *s1 [10], S; enum colors { red, black, green }; extern enum colors *en [6], C; union longOrShort { int first; long second; }; extern union longOrShort *u1 [12], U; \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4631.1.CC b/Tests/Spec.Conform/SPC4631.1.CC new file mode 100755 index 0000000..648ffa3 --- /dev/null +++ b/Tests/Spec.Conform/SPC4631.1.CC @@ -0,0 +1 @@ +/* Second file containing functions and variables accessed by main to run */ /* test Special Conformance 4.6.3.1 */ #include struct S { int a; float b; }; union U { int i; long L; }; extern int (*i2Ptr) (void); /* declare external variables */ extern char (*ch2Ptr) (void); extern long (*L2Ptr) (void); extern comp (*c2Ptr) (void); extern float (*f2Ptr) (void); extern double (*d2Ptr) (void); extern extended (*e2Ptr) (void); extern unsigned int (*ui2Ptr) (void); extern unsigned long (*uL2Ptr) (void); extern struct S (*struct2Ptr) (void), extStruct1, extStruct2; extern union U (*union2Ptr) (void), extUnion1, extUnion2; extern int DispI (int (*func) (void)); /* declare external functions */ extern char DispCh (char (*func) (void)); extern long DispL (long (*func) (void)); extern comp DispC (comp (*func) (void)); extern float DispF (float (*func) (void)); extern double DispD (double (*func) (void)); extern extended DispE (extended (*func) (void)); extern unsigned int DispUI (unsigned int (*func) (void)); extern unsigned long DispUL (unsigned long (*func) (void)); extern struct S DispS (struct S (*func) (void)); extern union U DispU (union U (*func) (void)); /***************************************************************************/ int ExternTest (void) { int count = 0; int i; char ch; long LL; comp c; float f; double d; extended e; unsigned int unInt; unsigned long unLong; struct S svar; union U uvar; count++; i = DispI (i2Ptr); if (i != 2) goto Fail; count++; ch = DispCh (ch2Ptr); if (ch != 'b') goto Fail; count++; LL = DispL (L2Ptr); if (LL != 9) goto Fail; count++; c = DispC (c2Ptr); if (c != 56) goto Fail; count++; f = DispF (f2Ptr); if (fabs (f - 97.9) > 0.0001) goto Fail; count++; d = DispD (d2Ptr); if (fabs (d - 25.5e-7) > 0.0001) goto Fail; count++; e = DispE (e2Ptr); if (fabs (e - 0.4) > 0.0001) goto Fail; count++; unInt = DispUI (ui2Ptr); if (unInt != 0x7E) goto Fail; count++; unLong = DispUL (uL2Ptr); if (unLong != 0xFEDCBA98) goto Fail; count++; svar = DispS (struct2Ptr); if ((svar.a != 18) || (fabs (svar.b - 0.3) > 0.0001)) goto Fail; count++; uvar = DispU (union2Ptr); if (uvar.i != 29) goto Fail; return 0; Fail: printf ("Failed ExternTest: count = %d\n", count); return 1; } /***************************************************************************/ int I2 (void) { return 2; } /***************************************************************************/ char Ch2 (void) { return 'b'; } /***************************************************************************/ long L2 (void) { return 9; } /***************************************************************************/ comp C2 (void) { return 8 * 7; } /***************************************************************************/ float F2 (void) { return 97.9; } /***************************************************************************/ double D2 (void) { return 25.5e-7; } /***************************************************************************/ extended E2 (void) { return 0.4; } /***************************************************************************/ unsigned int UI2 (void) { return 0x7e; } /***************************************************************************/ unsigned long UL2 (void) { return 0xfedcba98; } /***************************************************************************/ struct S S2 (void) { return extStruct2; } /***************************************************************************/ union U U2 (void) { return extUnion2; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4631.EXEC b/Tests/Spec.Conform/SPC4631.EXEC new file mode 100755 index 0000000..ca9b433 --- /dev/null +++ b/Tests/Spec.Conform/SPC4631.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.6.3.1 * set exit on echo compile spc4.6.3.1.cc compile spc4.6.3.1.cc keep=3/out if {status} == 0 echo compile spc4631.1.cc compile spc4631.1.cc keep=3/out1 if {status} == 0 link 3/out 3/out1 keep=3/out if {status} == 0 3/out else echo Unable to link Special Conformance Test 4.6.3.1 end else echo Unable to compile file spc4631.1.cc end else echo Unable to compile file spc4.6.3.1.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4632.1.CC b/Tests/Spec.Conform/SPC4632.1.CC new file mode 100755 index 0000000..e0e0248 --- /dev/null +++ b/Tests/Spec.Conform/SPC4632.1.CC @@ -0,0 +1 @@ +/* File spc4632.1.cc; the second source file which accesses the external */ /* arrays defined in the main source file. Part of Special Conformance */ /* Test 4.6.3.2 */ #include int ExternTest (void) { int count = 0; struct S { int a; float b; }; union U { int i; long L; }; /* Declare extern pointers */ extern int (*i2Ptr); extern char (*ch2Ptr); extern long (*L2Ptr); extern comp (*c2Ptr); extern float (*f2Ptr); extern double (*d2Ptr); extern extended (*e2Ptr); extern unsigned int (*ui2Ptr); extern unsigned long (*uL2Ptr); extern struct S (*struct2Ptr); extern union U (*union2Ptr ); /* also test pointer subscripting */ count++; if ((*(i2Ptr) != 8) || (i2Ptr [1] != 9)) goto Fail; count++; if ((*(ch2Ptr) != 'x') || (ch2Ptr [1] != 'y')) goto Fail; count++; if ((*(L2Ptr) != 17) || (L2Ptr [1] != 23)) goto Fail; count++; if ((*(c2Ptr) != 45000) || (c2Ptr [1] != 500000)) goto Fail; count++; if ((fabs (*(f2Ptr) - 123.456) > 0.0001) || (fabs (f2Ptr [1] - 6.0e7) > 0.0001)) goto Fail; count++; if ((fabs (*(d2Ptr) - 0.5e10) > 0.0001) || (fabs (d2Ptr [1] - 3.27) > 0.0001)) goto Fail; count++; if ((fabs (*(e2Ptr) - 7.4) > 0.0001) || (fabs (e2Ptr [1] - 9.9) > 0.0001)) goto Fail; count++; if ((*(ui2Ptr) != 10) || (ui2Ptr [1] != 11)) goto Fail; count++; if ((*(uL2Ptr) != 4) || (uL2Ptr [1] != 4)) goto Fail; count++; if ((struct2Ptr->a != 888) || ((struct2Ptr + 1)->a != 999)) goto Fail; count++; if ((fabs (struct2Ptr->b - 8.88) > 0.0001) || (fabs ((struct2Ptr + 1)->b - 9.99) > 0.0001)) goto Fail; count++; if ((union2Ptr->i != 7777) || ((union2Ptr + 1)->i != 0)) goto Fail; return 0; Fail: printf ("failure in ExternTest: count = %d\n", count); return 1; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4632.EXEC b/Tests/Spec.Conform/SPC4632.EXEC new file mode 100755 index 0000000..feafbad --- /dev/null +++ b/Tests/Spec.Conform/SPC4632.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.6.3.2 * set exit on echo compile spc4.6.3.2.cc compile spc4.6.3.2.cc keep=3/out if {status} == 0 echo compile spc4632.1.cc compile spc4632.1.cc keep=3/out1 if {status} == 0 link 3/out 3/out1 keep=3/out if {status} == 0 3/out else echo Unable to link Special Conformance Test 4.6.3.2 end else echo Unable to compile file spc4632.1.cc end else echo Unable to compile file spc4.6.3.2.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4633.1.CC b/Tests/Spec.Conform/SPC4633.1.CC new file mode 100755 index 0000000..1dc13a6 --- /dev/null +++ b/Tests/Spec.Conform/SPC4633.1.CC @@ -0,0 +1 @@ +/* File spc4633.1.cc; the second source file which accesses the external */ /* variables defined in the main source file. Part of Special Conformance */ /* Test 4.6.3.3 */ #include int ExternTest (void) { int count = 0; struct S { int a; float b; }; union U { int i; long L; }; /* Declare extern pointers */ extern int (*i2Ptr); extern char (*ch2Ptr); extern long (*L2Ptr); extern comp (*c2Ptr); extern float (*f2Ptr); extern double (*d2Ptr); extern extended (*e2Ptr); extern unsigned int (*ui2Ptr); extern unsigned long (*uL2Ptr); extern struct S (*struct2Ptr); extern union U (*union2Ptr ); count++; if (*(i2Ptr) != 8) goto Fail; count++; if (*(ch2Ptr) != 'x') goto Fail; count++; if (*(L2Ptr) != 17) goto Fail; count++; if (*(c2Ptr) != 45000) goto Fail; count++; if (fabs (*(f2Ptr) - 123.456) > 0.0001) goto Fail; count++; if (fabs (*(d2Ptr) - 0.5e10) > 0.0001) goto Fail; count++; if (fabs (*(e2Ptr) - 7.4) > 0.0001) goto Fail; count++; if (*(ui2Ptr) != 10) goto Fail; count++; if (*(uL2Ptr) != 4) goto Fail; count++; if ((struct2Ptr->a != 888) || (fabs (struct2Ptr->b - 8.88) > 0.0001)) goto Fail; count++; if (union2Ptr->i != 7777) goto Fail; return 0; Fail: printf ("Failure in ExternTest: count = %d\n", count); return 1; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4633.EXEC b/Tests/Spec.Conform/SPC4633.EXEC new file mode 100755 index 0000000..7ae432a --- /dev/null +++ b/Tests/Spec.Conform/SPC4633.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.6.3.3 * set exit on echo compile spc4.6.3.3.cc compile +t +e spc4.6.3.3.cc keep=3/out if {status} == 0 echo compile spc4633.1.cc compile +t +e spc4633.1.cc keep=3/out1 if {status} == 0 link 3/out 3/out1 keep=3/out if {status} == 0 3/out else echo Unable to link Special Conformance Test 4.6.3.3 end else echo Unable to compile file spc4633.1.cc end else echo Unable to compile file spc4.6.3.3.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4634.1.CC b/Tests/Spec.Conform/SPC4634.1.CC new file mode 100755 index 0000000..86f2491 --- /dev/null +++ b/Tests/Spec.Conform/SPC4634.1.CC @@ -0,0 +1 @@ +/* File spc4634.1.cc; the second source file which accesses the external */ /* variables defined in the main source file. Part of Special Conformance */ /* Test 4.6.3.4 */ #include int ExternTest (void) { int count = 0; struct S { int a; float b; }; union U { int i; long L; }; /* Declare extern pointers */ extern int (*i2Ptr); extern char (*ch2Ptr); extern long (*L2Ptr); extern comp (*c2Ptr); extern float (*f2Ptr); extern double (*d2Ptr); extern extended (*e2Ptr); extern unsigned int (*ui2Ptr); extern unsigned long (*uL2Ptr); extern struct S (*struct2Ptr); extern union U (*union2Ptr ); count++; if (*(i2Ptr) != 9) goto Fail; count++; if (*(ch2Ptr) != 'z') goto Fail; count++; if (*(L2Ptr) != 27) goto Fail; count++; if (*(c2Ptr) != 100000) goto Fail; count++; if (fabs (*(f2Ptr) - 12.3456) > 0.0001) goto Fail; count++; if (fabs (*(d2Ptr) - 0.65) > 0.0001) goto Fail; count++; if (fabs (*(e2Ptr) - 4.7) > 0.0001) goto Fail; count++; if (*(ui2Ptr) != 20) goto Fail; count++; if (*(uL2Ptr) != 88) goto Fail; count++; if ((struct2Ptr->a != 999) || (fabs (struct2Ptr->b - 9.99) > 0.0001)) goto Fail; count++; if (union2Ptr->i != 0) goto Fail; return 0; Fail: printf ("Failed ExternTest: count = %d\n", count); return 1; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4634.EXEC b/Tests/Spec.Conform/SPC4634.EXEC new file mode 100755 index 0000000..5c44ed8 --- /dev/null +++ b/Tests/Spec.Conform/SPC4634.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.6.3.4 * set exit on echo compile spc4.6.3.4.cc compile spc4.6.3.4.cc keep=3/out if {status} == 0 echo compile spc4634.1.cc compile spc4634.1.cc keep=3/out1 if {status} == 0 link 3/out 3/out1 keep=3/out if {status} == 0 3/out else echo Unable to link Special Conformance Test 4.6.3.4 end else echo Unable to compile file spc4634.1.cc end else echo Unable to compile file spc4.6.3.4.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4636.1.CC b/Tests/Spec.Conform/SPC4636.1.CC new file mode 100755 index 0000000..e46eb73 --- /dev/null +++ b/Tests/Spec.Conform/SPC4636.1.CC @@ -0,0 +1 @@ +/* File spc4636.1.cc; the second source file which accesses the external */ /* arrays defined in the main source file. Part of Special Conformance */ /* Test 4.6.3.6 */ int ExternTest (void) { int count = 0; struct S { int a; float b; }; union U { int i; long L; }; /* Declare extern pointers */ extern int (*i2Ptr); extern char (*ch2Ptr); extern long (*L2Ptr); extern comp (*c2Ptr); extern float (*f2Ptr); extern double (*d2Ptr); extern extended (*e2Ptr); extern unsigned int (*ui2Ptr); extern unsigned long (*uL2Ptr); extern struct S (*struct2Ptr); extern union U (*union2Ptr ); count++; if (*(i2Ptr) != 9) goto Fail; count++; if (*(ch2Ptr) != 'y') goto Fail; count++; if (*(L2Ptr) != 23) goto Fail; /* count++; if (*(c2Ptr) != 500000) goto Fail; */ count++; if (fabs (*(f2Ptr) - 6.0E7) > 0.0001) goto Fail; count++; if (fabs (*(d2Ptr) - 3.27) > 0.0001) goto Fail; count++; if (fabs (*(e2Ptr) - 9.9) > 0.0001) goto Fail; count++; if (*(ui2Ptr) != 11) goto Fail; count++; if (*(uL2Ptr) != 4) goto Fail; count++; if ((struct2Ptr->a != 999) || (fabs (struct2Ptr->b - 9.99) > 0.0001)) goto Fail; count++; if (union2Ptr->i != 0) goto Fail; return 0; Fail: printf ("Failure in ExternTest: count = %d\n", count); return 1; } \ No newline at end of file diff --git a/Tests/Spec.Conform/SPC4636.EXEC b/Tests/Spec.Conform/SPC4636.EXEC new file mode 100755 index 0000000..8284149 --- /dev/null +++ b/Tests/Spec.Conform/SPC4636.EXEC @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.6.3.6 * unset exit compile spc4.6.3.6.cc keep=3/spc4636 set errNo {status} if {errNo} == 0 compile spc4636.1.cc keep=3/spc4636.1 set errNo {status} if {errNo} == 0 link 3/spc4636 3/spc4636.1 keep=3/spc4636 set errNo {status} if {errNo} == 0 3/spc4636 else echo Unable to link Special Conformance Test 4.6.3.6 end else echo Unable to compile file spc4636.1.cc end else echo Unable to compile file spc4.6.3.6.cc end \ No newline at end of file diff --git a/Tests/Spec.Conform/UFILE1 b/Tests/Spec.Conform/UFILE1 new file mode 100755 index 0000000..df770b0 --- /dev/null +++ b/Tests/Spec.Conform/UFILE1 @@ -0,0 +1 @@ +main () { int x; \ No newline at end of file diff --git a/Tests/Spec.Conform/USERFILE2 b/Tests/Spec.Conform/USERFILE2 new file mode 100755 index 0000000..52dd54c --- /dev/null +++ b/Tests/Spec.Conform/USERFILE2 @@ -0,0 +1 @@ + x = TEN + NINE; if (x != 19) goto Fail; \ No newline at end of file diff --git a/Tests/Spec.Conform/spc21.3.0.1.cc b/Tests/Spec.Conform/spc21.3.0.1.cc new file mode 100755 index 0000000..3d68885 --- /dev/null +++ b/Tests/Spec.Conform/spc21.3.0.1.cc @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 21.3.0.1: Verification of exit, atexit functions */ /* */ /* The tester should verify that the sequence of messages "return from */ /* function 1", "return from function 2", "return from function 3" are */ /* displayed on the screen, and that the {status} shell variable is set to */ /* 3 upon completion of the program. */ /* */ #include /******************************************************************************/ void F1 () { printf ("Return from function 1\n"); } /******************************************************************************/ void F2 () { printf ("Return from function 2\n"); } /******************************************************************************/ void F3 () { printf ("Return from function 3\n"); } /******************************************************************************/ main () { int i; i = atexit (F3); if (i != 0) goto Fail; i = atexit (F2); if (i != 0) goto Fail; i = atexit (F1); if (i != 0) goto Fail; exit (3); Fail: printf ("Failure of atexit function in Special Conformance Test 21.3.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/spc21.3.0.2.cc b/Tests/Spec.Conform/spc21.3.0.2.cc new file mode 100755 index 0000000..ed333b5 --- /dev/null +++ b/Tests/Spec.Conform/spc21.3.0.2.cc @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 21.3.0.2: Verification of _exit function */ /* */ /* The tester should verify that the program halts and that the {status} */ /* shell variable is set to 10 upon completion of the program. No messages */ /* should be printed by any of the functions registered with atexit. */ /* */ #include /******************************************************************************/ void F1 () { printf ("Return from function 1\n"); } /******************************************************************************/ void F2 () { printf ("Return from function 2\n"); } /******************************************************************************/ void F3 () { printf ("Return from function 3\n"); } /******************************************************************************/ main () { int i; i = atexit (F3); if (i != 0) goto Fail; i = atexit (F2); if (i != 0) goto Fail; i = atexit (F1); if (i != 0) goto Fail; _exit (10); Fail: printf ("Failure of atexit function in Special Conformance Test 21.3.0.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/spc21.3.0.3.cc b/Tests/Spec.Conform/spc21.3.0.3.cc new file mode 100755 index 0000000..a670593 --- /dev/null +++ b/Tests/Spec.Conform/spc21.3.0.3.cc @@ -0,0 +1 @@ +/* */ /* Special Conformance Test 21.3.0.3: Verification of abort function */ /* */ /* The tester should verify that the program halts and that the {status} */ /* shell variable is set to -1 upon completion of the program. No messages */ /* should be printed by any of the functions registered with atexit. */ /* */ #include /******************************************************************************/ void F1 () { printf ("Return from function 1\n"); } /******************************************************************************/ void F2 () { printf ("Return from function 2\n"); } /******************************************************************************/ void F3 () { printf ("Return from function 3\n"); } /******************************************************************************/ main () { int i; i = atexit (F3); if (i != 0) goto Fail; i = atexit (F2); if (i != 0) goto Fail; i = atexit (F1); if (i != 0) goto Fail; abort (); Fail: printf ("Failure of atexit function in Special Conformance Test 21.3.0.3\n"); } \ No newline at end of file diff --git a/Tests/Spec.Conform/spc4411.exec b/Tests/Spec.Conform/spc4411.exec new file mode 100755 index 0000000..bbbeed3 --- /dev/null +++ b/Tests/Spec.Conform/spc4411.exec @@ -0,0 +1 @@ +* Exec file to run Special Conformance Test 4.4.1.1 * unset exit echo compile spc4.4.1.1.cc compile spc4.4.1.1.cc keep=14:spc4411.mn set errNo {status} if {errNo} == 0 echo compile spc4411.1.cc compile spc4411.1.cc keep=14:spc4411.1 set errNo {status} if {errNo} == 0 echo link spc4.4.1.1.cc link 14:spc4411.mn 14:spc4411.1 keep=14:spc4411 set errNo {status} if {errNo} == 0 echo execute spc4.4.1.1.cc 14:spc4411 else echo Unable to link Special Conformance Test 4.4.1.1 end else echo Unable to compile file spc4411.1.cc end else echo Unable to compile file spc4.4.1.1.cc end \ No newline at end of file diff --git a/Tests/Spec.Deviance/DOIT b/Tests/Spec.Deviance/DOIT new file mode 100755 index 0000000..220e360 --- /dev/null +++ b/Tests/Spec.Deviance/DOIT @@ -0,0 +1 @@ +{1} SPD17.2.0.1.CC {1} SPD17.2.0.2.CC {1} SPD17.2.0.3.CC {1} SPD17.2.0.4.CC {1} SPD17.2.0.5.CC {1} SPD17.2.0.7.CC {1} SPD17.3.0.1.CC {1} SPD17.3.0.2.CC {1} SPD17.3.0.3.CC {1} SPD17.5.0.1.CC {1} SPD17.5.0.2.CC {1} SPD17.6.0.1.CC {1} SPD17.6.0.2.CC {1} SPD17.6.0.3.CC {1} SPD17.7.0.1.CC \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.2.0.1.CC b/Tests/Spec.Deviance/SPD17.2.0.1.CC new file mode 100755 index 0000000..93ffdec --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.2.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 17.2.0.1: Ensure illegal parameters supplied to fopen */ /* are detected */ #include main () { FILE *f1; f1 = fopen ("123badfile", "r"); /* try to open file with invalid */ if (f1 != NULL) /* filename */ goto Fail; printf ("Passed Deviance Test 17.2.0.1\n"); return; Fail: printf ("Failed Deviance Test 17.2.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.2.0.2.CC b/Tests/Spec.Deviance/SPD17.2.0.2.CC new file mode 100755 index 0000000..18d925d --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.2.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 17.2.0.2: Ensure illegal parameters supplied to freopen */ /* are detected */ #include main () { FILE *f1; f1 = freopen ("123badfile", "r", f1); /* invalid stream to freopen */ if (f1 != NULL) goto Fail; printf ("Passed Deviance Test 17.2.0.2\n"); return; Fail: printf ("Failed Deviance Test 17.2.0.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.2.0.3.CC b/Tests/Spec.Deviance/SPD17.2.0.3.CC new file mode 100755 index 0000000..29cefd5 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.2.0.3.CC @@ -0,0 +1 @@ +/* Deviance Test 17.2.0.3: Ensure illegal parameters supplied to freopen */ /* are detected */ #include main () { FILE *f1; f1 = freopen ("3/thirdFile", "t", f1); /* try to open with invalid type */ if (f1 != NULL) goto Fail; printf ("Passed Deviance Test 17.2.0.3\n"); return; Fail: printf ("Failed Deviance Test 17.2.0.3\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.2.0.4.CC b/Tests/Spec.Deviance/SPD17.2.0.4.CC new file mode 100755 index 0000000..6bfd704 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.2.0.4.CC @@ -0,0 +1 @@ +/* Deviance Test 17.2.0.4: Ensure illegal parameters supplied to fclose */ /* are detected */ #include main () { FILE *f1; int i; i = fclose (f1); /* pass fclose an invalid file pointer */ if (i != EOF) goto Fail; printf ("Passed Deviance Test 17.2.0.4\n"); return; Fail: printf ("Failed Deviance Test 17.2.0.4\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.2.0.5.CC b/Tests/Spec.Deviance/SPD17.2.0.5.CC new file mode 100755 index 0000000..5d40266 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.2.0.5.CC @@ -0,0 +1 @@ +/* Deviance Test 17.2.0.5: Ensure illegal parameters supplied to fflush */ /* are detected */ #include main () { FILE *f1; int i; i = fflush (f1); /* pass fflush an invalid file pointer */ if (i != EOF) goto Fail; printf ("Passed Deviance Test 17.2.0.5\n"); return; Fail: printf ("Failed Deviance Test 17.2.0.5\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.2.0.7.CC b/Tests/Spec.Deviance/SPD17.2.0.7.CC new file mode 100755 index 0000000..9d1ca29 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.2.0.7.CC @@ -0,0 +1 @@ +/* Deviance Test 17.2.0.7: Ensure illegal parameters supplied to fopen */ /* are detected */ #include main () { FILE *f1; int i; f1 = fopen ("3/fourthFile", "99"); /* try to open with invalid type */ if (f1 != NULL) goto Fail; printf ("Passed Deviance Test 17.2.0.7\n"); return; Fail: printf ("Failed Deviance Test 17.2.0.7\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.3.0.1.CC b/Tests/Spec.Deviance/SPD17.3.0.1.CC new file mode 100755 index 0000000..80c438d --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.3.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 17.3.0.1: Ensure illegal setvbuf calls are detected */ #include main () { FILE *f1; char buf [80]; int i; i = setvbuf (f1, buf, _IOLBF, 0); /* call setvbuf before file opened */ if (!i) goto Fail; printf ("Passed Deviance Test 17.3.0.1\n"); return; Fail: printf ("Failed Deviance Test 17.3.0.1\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.3.0.2.CC b/Tests/Spec.Deviance/SPD17.3.0.2.CC new file mode 100755 index 0000000..d5d04c1 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.3.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 17.3.0.2: Ensure illegal setvbuf calls are detected */ #include main () { FILE *f1; char buf [80]; int i; f1 = fopen ("3/tmp", "w"); /* call setvbuf after I/O already done */ if (f1 == NULL) goto Fail1; i = fputc ('a', f1); /* write a character to the file */ if (i == EOF) goto Fail2; i = setvbuf (f1, NULL, _IONBF, 0); if (!i) goto Fail; printf ("Passed Deviance Test 17.3.0.2\n"); return; Fail: printf ("Failed Deviance Test 17.3.0.2\n"); return; Fail1: printf ("Unable to open work file for Deviance Test 17.3.0.2\n"); return; Fail2: printf ("Unable to write to file for Deviance Test 17.3.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.3.0.3.CC b/Tests/Spec.Deviance/SPD17.3.0.3.CC new file mode 100755 index 0000000..6222515 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.3.0.3.CC @@ -0,0 +1 @@ +/* Deviance Test 17.3.0.3: Ensure illegal setvbuf calls are detected */ #include main () { FILE *f1; char buf [80]; int i; f1 = fopen ("3/tmp", "w"); /* call setvbuf with an ivalid buffering type */ if (f1 == NULL) goto Fail1; i = setvbuf (f1, buf, 3, 80); if (!i) goto Fail; printf ("Passed Deviance Test 17.3.0.3\n"); return; Fail: printf ("Failed Deviance Test 17.3.0.3\n"); return; Fail1: printf ("Unable to open work file for Deviance Test 17.3.0.3\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.5.0.1.CC b/Tests/Spec.Deviance/SPD17.5.0.1.CC new file mode 100755 index 0000000..6c45bcb --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.5.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 17.5.0.1: Ensure illegal parameters passed to fseek are */ /* detected */ #include #include main () { FILE *f1; int i, j; i = fseek (f1, 10L, SEEK_SET); /* try to seek on unopened stream */ if (!i) goto Fail; i = fseek (f1, 10L, SEEK_CUR); if (!i) goto Fail; i = fseek (f1, 10L, SEEK_END); if (!i) goto Fail; printf ("Passed Deviance Test 17.5.0.1\n"); return; Fail: printf ("Failed Deviance Test 17.5.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.5.0.2.CC b/Tests/Spec.Deviance/SPD17.5.0.2.CC new file mode 100755 index 0000000..5e4aa85 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.5.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 17.5.0.2: Ensure illegal parameters passed to ftell */ /* are detected */ #include #include main () { FILE *f1; long L1; errno = 0; L1 = ftell (f1); /* try to get current file position */ if ((L1 != -1L) || (errno == 0)) /* on unopened stream */ goto Fail; printf ("Passed Deviance Test 17.5.0.2\n"); return; Fail: printf ("Failed Deviance Test 17.5.0.2\n"); return; } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.6.0.1.CC b/Tests/Spec.Deviance/SPD17.6.0.1.CC new file mode 100755 index 0000000..dfcbdb9 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.6.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 17.6.0.1: Ensure illegal parameters for fgetc are detected */ #include main () { FILE *f1; int i; i = fgetc (f1); /* trying to read an unopened stream */ if (i != EOF) goto Fail; if (! (feof (f1)) ) /* ensure error and not just EOF */ goto Fail; printf ("Passed Deviance Test 17.6.0.1\n"); return; Fail: printf ("Failed Deviance Test 17.6.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.6.0.2.CC b/Tests/Spec.Deviance/SPD17.6.0.2.CC new file mode 100755 index 0000000..24458ea --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.6.0.2.CC @@ -0,0 +1 @@ +/* Deviance Test 17.6.0.2: Ensure illegal parameters for getc are detected */ #include main () { FILE *f1; int i; i = getc (f1); /* try to read from closed stream */ if (i != EOF) goto Fail; if (! (feof (f1)) ) goto Fail; printf ("Passed Deviance Test 17.6.0.2\n"); return; Fail: printf ("Failed Deviance Test 17.6.0.2\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.6.0.3.CC b/Tests/Spec.Deviance/SPD17.6.0.3.CC new file mode 100755 index 0000000..57d4b33 --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.6.0.3.CC @@ -0,0 +1 @@ +/* Deviance Test 17.6.0.3: Ensure illegal parameters for ungetc are detected */ #include FILE *f1; int i; main () { i = ungetc ('a', f1); /* trying to read an unopened stream */ if (i != EOF) goto Fail; if (! (feof (f1)) ) /* ensure error and not just EOF */ goto Fail; printf ("Passed Deviance Test 17.6.0.3\n"); return; Fail: printf ("Failed Deviance Test 17.6.0.3\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/SPD17.7.0.1.CC b/Tests/Spec.Deviance/SPD17.7.0.1.CC new file mode 100755 index 0000000..afb11db --- /dev/null +++ b/Tests/Spec.Deviance/SPD17.7.0.1.CC @@ -0,0 +1 @@ +/* Deviance Test 17.7.0.1: Ensure illegal parameters for fgets are detected */ #include FILE *f1; char string [80], *s; int i; main () { s = fgets (string, 90, f1); /* trying to read an unopened stream */ if (s != NULL) goto Fail; if (! (feof (f1)) ) /* ensure error and not just EOF */ goto Fail; printf ("Passed Deviance Test 17.7.0.1\n"); return; Fail: printf ("Failed Deviance Test 17.7.0.1\n"); } \ No newline at end of file diff --git a/Tests/Spec.Deviance/TEST b/Tests/Spec.Deviance/TEST new file mode 100755 index 0000000..a773a55 --- /dev/null +++ b/Tests/Spec.Deviance/TEST @@ -0,0 +1 @@ +echo {1} cmpl {1} keep=3/t >3/tt unset exit 3/t \ No newline at end of file diff --git a/backup b/backup new file mode 100755 index 0000000..ef53042 --- /dev/null +++ b/backup @@ -0,0 +1 @@ +if "{#}" != "1" echo Form: backup [day] exit 65535 end set dest /library/mike/{1}/cc set list make make2 smake linkit linkit2 count backup cc.notes set list {list} CC.pas CC.rez CC.rez2 set list {list} CCommon.pas CCommon.asm CCommon.macros set list {list} MM.pas MM.asm MM.macros set list {list} Table.pas Table.asm Table.macros set list {list} Symbol.pas Symbol.Print Symbol.asm Symbol.macros set list {list} Scanner.pas Scanner.debug Scanner.asm Scanner.macros set list {list} Asm.pas set list {list} Expression.pas Expression.asm Exp.macros set list {list} Parser.pas set list {list} CGC.pas CGC.asm CGC.macros set list {list} CGI.pas CGI.Comments CGI.Debug set list {list} ObjOut.pas ObjOut.asm ObjOut2.pas ObjOut2.asm ObjOut.macros set list {list} Native.pas Native2.pas Native.asm Native.macros set list {list} DAG.pas DAG2.pas set list {list} Gen.pas set list {list} Header.pas Header2.pas unset exit create {dest} >.null >&.null for i in {list} newer {dest}/{i} {i} if {Status} != 0 copy -c {i} {dest}/{i} end end \ No newline at end of file diff --git a/cc.notes b/cc.notes new file mode 100755 index 0000000..8cbb549 --- /dev/null +++ b/cc.notes @@ -0,0 +1 @@ +ORCA/C 2.1.0 Copyright 1996, Byte Works Inc. -- Change List -------------------------------------------------------------- 2.1.0 1. Bugs squashed. See bug notes, below. 2. New bit added for vararg stack repair removal. See #pragma optimize, below. 3. There have been several changes to assert(). See the Manual Erratta for page 343 for details. 4. C supports the extended character set. See "Extended Characters." 5. You can create defaults that are used in all of your C programs using the new defaults.h file. See "The Default .h File." 6. ORCA/C supports // comments. See "// Comments." 2.0.3 1. Bugs squashed. See bug notes, below. 2.0.2 1. Bugs squashed. See bug notes, below. 2.0.1 1. Bugs squashed. See bug notes, below. -- Manual Erratta ----------------------------------------------------------- p. 40 The description of the action function says it takes a single integer parameter. Actually, it takes two parameters, as shown in the example on page 41. Both the description and the sample on page 41 indicate that the action procedure for an NDA should return void. Actually, the action routine should return int, returning 0 if it handled the action and 1 if it did not. The correct function looks like this: int Action (long param, int code) { int handledEvent = 0; <<>> return handledEvent; } The description of the init function doesn't point out some important limitations. When this call is made at shutdown time, your NDA has already been placed in a dormant state, and all RAM has been deallocated. (This happened when the close function was called.) If you need dynamic memory for any purpose, be sure you obtain a valid user ID, and that you dispose of the memory after you are finished with it. Do not rely on C memory management functions at shutdown time. Static variables are safe, though, and can be used to pass information to the init function for use at shutdown time. p. 67 Delete the paragraph starting "One important point is that you should never reinitialize the Text Tool Set. ..." ORCA/C no longer uses the Text Tool Set for routine input and output, and definitely does not use it for I/O redirection. p. 100 The text does not mention the sixth default character. It is not used by PRIZM, though. For details on the 6th default character (as well as the 5th) see page 193, where their use by the text based editor is described. p. 101 The sample SYSTABS line at the top of the page should start 8 100110 p. 107 The table shows the language number for C as 7. It should be 8. p. 240 The discussion of escape sequences states that numeric escape sequences can contain from one to three digits. This was true until ORCA/C 2.1, when the compiler was changed to respect the ANSI C standard. The compiler will now scan an octal numeric escape sequence until no more octal characters are found, and it will scan a hexadecimal numeric escape sequence until no more hexadecimal characters are found. In both cases, the result is then anded with 0x00FF to yield a single character. The discussion concerning floating-point constants is misleading. While constants are indeed handled as extended values in the executable program, the compiler itself uses double values for the constants internally, so you need to adhere to the valid exponent range for double values, and you should expect to see accuracy in constants that is in line with double values. p. 241 ORCA/C now supports // comments. See "// Comments," below. p. 250 Several things are listed that will cause a .sym file to stop or not be built at all. Add to this list a #append, which does not work like a #include. It's worth keeping in mind that #append in included in ORCA/C solely for the purpose of appending files of a different language. There are several advantages to using #append to tack assembly language source to the end of a C source file, but there is no other place in ORCA/C where a #append is more useful than a #include. p.258 The #pragma ignore directive supports a new bit. Bit 3 controls whether // comments are allowed. If bit 3 is set, as in #pragma ignore 0x0008 ORCA/C supports // comments. If bit 3 is clear, ORCA/C does not support // comments, which are not actually allowed in ANSI C programs. See "// Comments," below, for a complete description of // comments. p. 263 1. The discussion of NDAs is on page 40, not page 58. 2. There is a new optimization bit for #pragma optimize. See #pragma optimize, below. p. 337 The ORCA/C compiler is intended as a faithful implementation of ANSI C with some extensions, but there have always been some library functions from ANSI C that were missing in ORCA/C. Chapter 19 should start with a summary of these omissions. They are: locale.h This header file is missing completely, along with all of its functions. stdlib.h The functions mblen(), mbstowcs(), mbtowc(), wcstombs() and wctomb() are missing. These are related to locale.h. string.h strcoll() and strxfrm() are missing. These are related to locale.h. time.h The function strftime() is missing. p. 343 The documentation states that assert() uses exit(-1) to exit a program. Actually, it uses abort(). Beginning with ORCA/C 2.1, assert() prints a string that includes the assertion itself, not just the line number and file name. The assertion has the form Assertion failed: file :hd:foo.cc, line 47; assertion: bar==1 The documentaion states assert() writes to stdout. Beginning with ORCA/C 2.1, it writes to stderr. p. 353 The discussion of _exit() should note that the _exit() function is an extension to ANSI C. p. 375 The discussion of isascii() should note that isascii() is an extension to ANSI C. p. 376 The discussions of iscsym() and iscsymf() should note that these functions are extensions to ANSI C. p. 377 The discussion of isodigit() should note that isodigit() is an extension to ANSI C. p. 396 The discussion of strpos() and strrpos() should note that the these functions are an extension to ANSI C. p. 398 The discussion of strrpbrk() should note that the strrpbrk() function is an extension to ANSI C. p. 404 The discussions of toascii() and _tolower should note that they are extensions to ANSI C. p. 405 The discussion of _toupper should note that _toupper is an extension to ANSI C. p. 444,445 The control codes to turn the cursor on and off are no longer used in the .CONSOLE driver, which is what the current version of ORCA/C uses for all text output. In the .CONSOLE driver, the cursor is always off unless it is waiting for a character. -- Compiler changes introduced in C 2.1.0 ----------------------------------- The Default .h File ------------------- The default .h file is a new way for you to set up compiler options that you want to use on every C source file you compile. Here's how it works: When ORCA/C starts, it begins by processing any command line parameters. Next, it looks for a file called defaults.h in the library folder. Finally, it compiles your source file. When ORCA/C looks for the defaults.h file, it behaves almost as if your program had started with the line #include The only differences are that the file doesn't have to exist (and if it doesn't no error is generated), the line is never shown in your source file, and the line number counter is not incremented. You can put absolutely anything you like in this file. The intent is to use it for pragmas or other preprocessor directives that you would like to become defaults for all of your programs, but there is no restruction that prevents you from putting other things in the file. WARNING: If you add a defaults.h file, be sure and delete all .sym files. .sym files are created by the compiler to make recompiling programs faster. They need to be recreated with the new information from the defaults.h file, but the compiler will not notice the presense of the defaults.h file if it is compiling a .sym file created with a previous version of the compiler. // Comments ----------- ORCA/C supports // comments. These comments begin with the characters //, and continue to the end of the physical line. // comments are a flagrant violation of the ANSI C standard. This is legal ANSI C, and it should print 4: a = 8//* yep, this is legal */ 2 ; printf("All ANSI C compilers should now print 4! %d\n", a); To restore ANSI conformance, use the #pragma ignore directive. Setting bit 3 (a value of 8) tells ORCA/C to allow // comments. This is the default. Clearing bit 3 tells ORCA/C not to look for // comments. To restore ANSI conformance for all programs, use this directive in the defaults.h file. (see "The Default .h File," above.) Extended Characters ------------------- Bear with me. This is an ASCII file, and it describes non-ASCII material. Beginning with version 2.1, the PRIZM desktop editor supports the full Apple extended character set. A file called FontTest on the samples disk shows the complete character set, and also contains a table that shows how to type each character from a U.S. English keyboard. C supports the use of extended characters in strings, comments, identifiers, and for a few mathematical operations. Any character you can type from PRIZM (or for that matter, any character with an ordinal value in [1..12, 14..255]) can appear in a string or comment. The ordinal value of the character matches the values shown in FontTest, as well as several official Apple publications. Keep in mind that many output devices, including Apple's text console driver, do not support all of these characters. ORCA/C will properly send extended characters to whatever output device you choose, but what happens when the output device tries to handle the character varies from device to device. Many of the characters in the extended character set are used in languages oter than English, and are now allowed in identifiers. There are two ways to think about which characters will work in an identifier. The simple way is to remember that all characters that look like a graphically modified ASCII alphabetic character or a Greek alphabetic character are allowed in identifiers. For example, an a with two dots above it is now legal in an identifier. The more exact, and naturally more complicated way to think about which characters are allowed in an identifier is to list all of them. Since this is an ASCII file, I'll list the ordinal values--you can cross reference the values in FontTest. The ordinal values of the extended characters that are allowed in identifiers are [$80..$9F, $A7, $AE, $AF, $B4..$B9, $BB..$BF, $C4, $C6, $CB..$CF, $D8, $DE, $DF]. In addition, ORCA/C supports several extended characters as shortcuts for multi-character mathematical operations. These are: ordinal value description substitutes for ------------- ----------- --------------- $C7 two < << $C8 two > >> $AD not equal != $B2 less than or equal <= $B3 greater than or equal >= $D6 division (- with dots) / Finally, the non-breaking space, sometimes called the sticky space (ordinal value $CA), is treated exactly like a standard space character. #pragma optimize ---------------- In brief, there is a new optimization bit. Setting bit 6 (a value of 64) turns off stack repair code around variable argument function calls. The rest of this section describes when the stack repair code is generated, why, and the side effects of using this optimization--or not using it. In variable argument functions (functions with ... as the last "parameter") it is illegal to pass fewer parameters than the function expects, or to pass parameters of a type different than the function expects. For example, both of these statements are illegal in ANSI C, even though few if any compilers can detect the error (and those that do are blocking some legal--albeit stupid--C code.): printf("%d %d", 4); printf("%d", 4.5); ORCA/C has always taken advantage of this fact to generate code that is more efficient and compatible with the other ORCA languages. With all optimizations on, programs containing the above statements will corrupt the stack, generally leading to a crash. On the other hand, ORCA/C did not allow this statement: printf("%d", 4, 5); Contrary to all common sense, the ANSI standard says this statement is legal IF THE APPROPRIATE HEADER FILE IS INCLUDED, even though the first two are not. Beginning with ORCA/C 2.1, this statement will work. Note that in keeping with the ANSI standard, this call and others like it only work if the function is properly defined with a prototyped variable argument parameter list. There are two undesireable side effects, though. First, all function calls to a variable argument function are surrounded by extra stack repair code, even if you set optimization bit 3. (This bit turns off stack repair code.) This increases code size and slows a program down. Sometimes these changes are noticeable, or even dramatic. Second, native code peephole optimization is always disabled when stack repair code is in use, so you loose another optimization if you do not use this one. Turning this optimization on means ORCA/C is no longer strictly in compliance with the ANSI standard. For strict compliance, you should leave stack repair code on for variable argument functions. You also need to disable stack repair code in any user-defined function that uses the va_arg() function, since this function is not compatible with stack repair code. For strict compliance, then, use at least #pragma optimize 0x0008 You can also add all of the other optimizations except removal of stack repair code around variable argument function calls and remain ANSI compliant, so this pragma will also work with all ANSI C programs: #pragma optimize 0x003F If you use #pragma debug 0x0010 to enable stack check debug code, the compiler will still flag variable argument functions that do not consume all arguments as a run-time error, even though ANSI C does allow them. -- Bugs from C 2.0.3 that have been fixed ----------------------------------- 1. Corrected a very rare bug that caused an unreliable value to be used in determining the type of an assignment statement. 2. Converting a value larger than 2147483647.0 from a real representation to an unsigned long integer representation did not generally work correctly. (Soenke Behrens) 3. Variables declared as "unsigned" were treated as "int" rather than "unsigned int". (Soenke Behrens, Philipp Vandry) 4. isgraph(' ') was true; it now correctly returns 0. (Soenke Behrens) 5. When asked to scan 65536 or more bytes, memchr actually scanned an extra 65536 bytes, often returning an incorrect result. (Soenke Behrens) 6. scanf("%d", &i) did not return EOF if it was used twice in succession, once with a numeric line followed by a return, and then pressing Control-@ o signal and end of file. (Sharon Barbaccia) 7. A switch statement with a default label but no case labels now generates the correct code to jump to the default label. (Animasia, Soenke Behrens, Michael Hackett) 8. In textedit.h, the last parameter to TEInsert was a Long; it has been changed to Handle. (Norm Dodge) 9. In time.h, NULL and size_t are now declared. (Soenke Behrens) 10. In time.h, string.h, stdio.h and stdlib.h, several functions that should have had const arguments do, now. (Soenke Behrens) 11. 0x8000 * 1 and 0x80000000 * 1 are now evaluated correctly. (Note: This actually showed up as a pointer offset bug, where *ptr = (char *)0x00C000; int offset = -32768; gave an incorrect result for ptr + offset). (Soenke Behrens, David Empson) 12. In expressions that could be evaluated at compile time, results that overflowed an integer frequently resulted in the constant being improperly promoted from an integer or unsigned to a long or unsigned long. Examples of expressions that would cause this kind of error are (65533U + 1U) / 2 and 0x8000|1. (Soenke Behrens, David Empson, Jay Krell) 13. In expressions that could be evaluated at compile time, binary operations involving an unsigned and integer were treated as an integer, when they should be treated as unsigned. This applies both to short and long operands. (Soenke Behrens, David Empson, Jay Krell) 14. The first and last parameter to FWEntry were reversed by the tool glue code. (Soenke Behrens, David Empson) 15. Storing multiple long values through a pointer stored in a global or static variable, as in a->b = a->c = 0L; where b and c are long and a is a global pointer, did not store the correct value in any but the rightmost operand. (Soenke Behrens, Derek Taubert) 16. Code generation has been improved for optimized code when a value is stored through a global or static pointer. 17. A linefeed between a macro name and the ( before the macro arguments caused a spurious compiler error. (Soenke Behrens, Jay Krell) 18. When skipping tokens due to a preprocessor command, ORCA/C was flagging # tokens from assembly language code as an error. Frankly, I can read the standard either way here. It's clear that skipped code must be tokenized. It is not clear whether # is allowed as a token in skipped code. Since I've gotten close to a bazilion complaints about this, though, I'm streatching things to allow # in skipped code, even without using the ignore pragma. (Soenke Behrens, Matt Ackeret) 19. In misctool.h, the fields in the HexTime struct were reversed, causing problems with the WriteTimeHex call. (Soenke Behrens, David Empson) 20. In stdio.h, fputc(), putchar() and ungetc() were declared with char parameters that should have been declared as int. In ctype.h, the same is true for tolower() and toupper(). (Soenke Behrens) 21. signal.h did not define sig_atomic_t; (Soenke Behrens) 22. Loads of double values were not performed correctly by the FPE version of the SysFloat library, resulting in a large loss of precision. (Soenke Behrens, Dirk Froehling, Frank Gizinski, Doug Gwyn) 23. Function parameters of type (const void *) generated an error when a pointer type was passed, rather than treating all pointer types as compatible. (Animasia) 24. There are several technical violations of the ANSI C namespace for header files. Basically, ANSI C says a compiler can't declare names in headers other than those documented in the standard unless they follow some very specific rules. Identifiers that start with an underscore and are followed by another underscore or an uppercase letter are reserved for use by the implementation. If you avoid these and all names explicitly defined by ANSI C, you should not have problems. Because ORCA/C defines some names other than those declared in the standard, and also because these names do not start with an underscore followed by an underscore or uppercase letter, there is the very slight potential that a program that should compile correctly won't. This bug can be corrected with the new libraries by defining a macro __KeepNamespacePure__ before including any header files. At some point I plan to define a header file that is always included, and you could define this macro there for 100% ANSI namespace compatibility. Until that time, though, the bug technically will continue to exist, but you have an easy workaround: just define the macro like this: #define __KeepNamespacePure__ 0 before the #include's in any file that should compile under ANSI C, but has namespace problems. (Soenke Behrens) 25. The various arguments and return types in math.h were declared as extended; they have been changed to double. (This actually doesn't make any difference, since all arguments and return types are promoted to extended anyway.) (Soenke Behrens) 26. The second parameter of the modf() function was of type (int *); this has been changed to (double *). (Soenke Behrens, Jay Krell) 27. In starg.h, va_end was declared as a function, when it must be a macro. It is now a macro. (Soenke Behrens) 28. localtime() now sets tm_isdst based on the BRAM setting. You can change the BRAM setting using the Clock CDev. (Soenke Behrens, Marlin Allred) 29. Mixing an integer 0 with a pointer in a conditional expression, as in void *p, *q = 0xdeadbeef; p = (1) ? 0 : q; generated incorrect code. (Soenke Behrens, Devin Reade) 30. If all of the following contitions are met, the 2.0.3 compiler crashes: a. Debug code is turned on (as in #pragma debug -1). b. A struct type is defined, and one of the elements of the struct type is a pointer back to the same struct type. (Think linked lists.) c. A function is defined containing a variable of this struct type, and that variable is the first variable processed when the compiler builds the debug symbol table. (Soenke Behrens) 31. Initlializers did not work for types defined like "static const struct foo bar[] = " Leaving out const worked fine. (Soenke Behrens) 32. Using const after a struct or union typedef name and before the variable name, as in struct charname { const char *symbol; const char *crypted; }; static struct charname const charname[3]; caused a spurious compiler error. (Soenke Behrens) 33. Casting an unsigned long value to double did not work correctly when the value being cast could not be evaluated until run-time, and when the value exceeded 0x7FFFFFFFul. (Soenke Behrens, Philipp Vandry) 34. Ignoring a long value returned by a tool call by casting the result to void, as in (void) ConvSeconds (TimeRec2ProDOS, 0L, (Pointer) &time); left the results on the stack, which generally resulted in a crash. The value is correctly removed, now. (Soenke Behrens, David Empson) 35. In some cases, nesting an increment or decriment operator around another increment or decrement operator, as in foo[*sp++]++ generated incorrect code. (Soenke Behrens) 36. Declaring a function using prototyped parameters, then defining it with K&R parameters, as in extern void foo (int *, int *); void foo (bar, gorp) int *bar, *gorp; {} generated incorrect code for accessing the parameters. (Soenke Behrens) 37. The compiler did not flag an error when an old-style struct parameter was used in a prototyped function declatation, as in: void foo (int x) struct bar = {1,2}; { return; } (Peter Watson, Soenke Behrens) 38. The predefined macros __LINE__, __STDC__ and __ORCAC__ did not work correctly when used with the ## operator. (Soenke Behrens, Jay Krell) 39. The __VERSION__ macro was not corrently updated in several earlier versions. It is now in lock-step with the version number printed when ORCA/C compiles a program, making it much more likely that it will stay correct. (Michael Hackett) 40. scanf() and its cousins incremented the number of items scanned when a %d or %i specifier encountered an input stream with no matching number. For example, sscanf("foo","%d",&bar) returned 1, when it should return 0, indicating that no number was found in the input stream. (Soenke Behrens) 41. When handling character set specifiers, scanf() and its cousins are supposed to allow ] as the first character in a set. For example, "%[]]" should scan ']', while "%[^]]" should scan all but ']'. This works correctly, now. (Jay Krell, Soenke Behrens) 42. With a file opened as "rb+", writing a single character and then closing the file did not always write the character to the output file. Multiple character writes would succeed. (Peter Watson, Soenke Behrens) 43. When a file is opened for reading and writing (as with "r+"), then a read is done, followed by an fflush(), the file should be available for output. In ORCA/C 2.0.3, it was not reset so output could occur. Note that this is generally no big deal, since the behavior of fflush() is undefined if the most recent operation on the file was input. In other words, the file position is not reliable. In general, you should use fseek(), fsetpos() or rewind() to change a file from input to output mode, not fflush(). (Soenke Behrens) 44. fflush(NULL) should flush all open streams. Starting with this version, it does. 45. With output redirected to a file and input comming from the keyboard, pressing the return key echoed the return that should have shown up on the screen to the output file. (Soenke Behrens, David Empson) 46. ORCA/C was allowing prototyped parameter lists with types but no identifier, as in foo (int, float) in both function declarations and function definitions. They should only be allowed in function declarations, and now cause an error if the identifier is missing in a function definition. (Soenke Behrens) 47. Variable argument functions that pass too many parameters are legal, and should not cause the compiler to behave in an unexpected way. ORCA/C now allows such function calls. See #pragma optimize for some details. (Soenke Behrens) 48. Assignments of structs or unions were sometimes removed from a loop by the loop invariant removal optimization when they should not have been removed. (Animasia) 49. A unary + operator was not allowed at the start of an expression. (Soenke Behrens) 50. When calling a pascal function from the C compiler's inline assembler, the compiler did not capitolize the identifier, resulting in link errors. (Jay Krell, Soenke Behrens) 51. ORCA/C 2.0.3 did not accept -1 as a value for period in #pragma nda, although documentation said it would. It now accepts a leading + or -. (Peter Watson, Soenke Behrens) 52. The compiler complained with "identifier expected" when doing something like: typedef char *ptr; typedef void *vptr; #define ptr vptr It should not care, since the preprocessor is a simple text substitution system. (Jay Krell, Soenke Behrens) 53. Multiple ## operators, as in #define cat(a,b,c) a##b##c were not handled correctly. (Soenke Behrens) 54. #append was not resetting the line counter used by the __LINE__ macro. It does, now. (Soenke Behrens) 55. When handling numeric escape sequences like '\x0077', ORCA/C has always limited the number of numeric characters actually scanned. In this specific example, the result would have been two characters, one with a value of 0x07 and another with the value '7'. According to the ANSI standard, all characters that can be included in a numeric sequence should be accepted. This, the above example should give a single character with a value of 0x77; it does now. (Dave Huang, Soenke Behrens) 56. printf("%#.0x", 0) should not print anything; it was printing 0x. (Soenke Behrens) 57. scanf with the '[' format specifier treated an input string with no matching characters as a valid match, returning a null string. It should have treated an input sequence with no matching characters as an error. (Soenke Behrens) 58. In several places, if output was suppressed and a scanf input failed, scanf returned one less than the correct number of inputs scanned. 59. Several functions were defined as macro overrides, and the macro overrides called other standard C functions. This could cause a problem in obscure cases where the function defined as a macro was used, but the user replaced the standar function it calls with one of their own. All of these cases have been corrected in some way so this cannot happen. The affected functions are: stdio.h: getc(), putc(), rewind(), setbuf() (Soenke Behrens) 60. Several functions were defined as macro overrides. This works fine unless the function is used form a program that does not include the header file. These functions have all been recreated as true library functions that will link into a program whether or not the header file is included. In cases where is more efficient to use the macro than to make a function call, the macro definition has been left in place. This is not a violation of the standard, but if if bothers you, you can eliminate the macro and replace it with the header file form shown in the ANSI standard or any correct C reference manual. If you do this, your program may end up a little larger or slower, but it will still work, since the functions do exist in ORCALib. The affected functions are: stdio.h: getc(), putc(), rewind(), setbuf() ctype.h: isalnum(), isalpha(), iscntrl(), isdigit(), isgraph(), islower(), isprint(), ispunct(), isspace(), isupper(), isxdigit() (Soenke Behrens) 61. Definitions like extern int foo = 0; are now legal. Once you wade through the technical language of the standard, it turns out that this declaration works exactly as if the extern is left off. Note that this definition is illegal in virtually all dialects of C except ANSI C. In particular, it is not legal in either K&R C or C++. Since there is no real reason to ever use it, I recomment you don't. (Soenke Behrens) 62. When the compiler found a single error, it ended with the message "1 errors found." It now ends with "1 error found." 63. ORCA/C now supports tenative definitions. Basically, this means that variables declared at the program level can be declared as many times as you like, with or without the extern qualifier. The only restrictions are: 1. The types must match on all of the declarations and definitions. 2. A variable can only get an initializer in one place, even if the same initializer is used in all places. That place does NOT have to be the last place the variable appears, though. 3. If a variable is declared without the static qualifier, it cannot be declared in any other source file without the static qualifier. This isn't really a change, but the restriction still applies. Note that you can use extern and an initializer at the same time, now. (See bug 61.) The result is a declaration, though, not a definition. In other words, if extern int foo = 4; appears in one source file, it is an error if int foo; appears in some other source file; you will get i duplicate symbol error in the linker. If the first instance is changed to extern int foo; then this is a definition, and references to the variable actually use the one declared in the other source file. (Soenke Behrens) 64. Making a function call though a variable that is declared but not a function, as in int foo; foo(4); did not generate an error, and caused various problems, like incorrect code generation or compile time hangs. This will now generate an error. (David Empson, Soenke Behrens) 65. If the last include in a source file was followed immediately by a #endif, the compiler generated a spurious error whenever a .sym file was available. (Jay Krell, Soenke Behrens, JoeV16@AOL.COM, Michael Hackett) 66. assert() now prints the argument as a string, in addition to the file and line number. (Soenke Behrens) 67. asert() now writes to stderr, not stdout. (Soenke Behrens) 68. In some situations where a number is referenced indirectly, and added to itself, and when intermediate code optimization was used, the compiler could fail with a terminal compiler error. One example that caused this problem is: #pragma optimize 1 ... x = ptr->field + 1 + (ptr->field + 1); (Guy Umbright, Michael Hackett) 69. The midiSynth tool call GetMSData needed a tool glue routine; it has one, now. (Dave Tribby, Michael Hackett) 70. String constants formed using the macro stringization operator (#) were always disposed of at the end of a subroutine. This caused problems if the resulting string was used to initialize a static variable, since ORCA/C creates the static variable strings long after the subroutine is complete. (Philippe Manet, Michael Hackett) 71. strstr("abc", "") took an excessive amount of time to return an incorrect result. It now returns "abc", as required when the search string is the null string. (Doug Gwyn, Michael Hackett) 72. fwrite() now returns a correct element count when a disk full error occurs during a write. (Todd Whitesel, Michael Hackett) 73. The Gamm.cc benchmark gave incorrect results. This was due to a coding error in the benchmark itself. It has been corrected on the latest samples disk. 74. Pointers to functions were not entered in the debug table properly, causing debuggers to have a variety of problems. Debuggers generally show what a pointer points to, and there's no realistic way to do that for a pointer to a function, so the compiler now enters pointers to functions in the debug symbol table as if they are pointers to integers. (Michael Hackett) -- Bugs from C 2.0.2 that have been fixed ----------------------------------- 1. Debug code was inadvertantly left in the 2.0.2 compiler release. This could cause crashes or entry into a debugger, as well as extraneous text output during a compile. (Joe Wankerl) 2. The comments in stdarg.h were ended too early, so stdarg.h did not compile. -- Bugs from C 2.0.1 that have been fixed ----------------------------------- 1. The #line directive does not set the source file in a way that causes the debugger to use a different source file. (Gary Desrochers) 2. The #line directive now allows a line number of 0. 3. The results of the #line directive are now saved in the .sym file, so file names and line numbers are preserved when the .sym file is read. 4. stdarg.h has been modified to work with the stricter error checking for type casts implemented in C 2.0.1. (Doug Gwynn) -- Bugs from C 2.0 that have been fixed ------------------------------------- 1. In desk.h, added CloseNDAbyWinPtr to match TBR #1. Apple's original spelling (CloseNDAByWinPtr) has been retained for compatibility with existing source. (Dave Tribby) 2. In locator.h, an extraneous ; has been removed. (Dave Tribby, John Mills) 3. In sane.h, the spellings DecForm and Decimal have been added so Apple's naming scheme in the remainder of the file will work. (Dave Tribby) 4. In MidiSynth.h, the following spelling corrections were made: from to ---- -- WavAddrB WaveAddrB FindTuneA TineTuneA (Dave Tribby) 5. In MidiSynth.h, added SetBasicChan to match TBR. Apple's original spelling (SetBasicChannel) has been retained for compatibility with existing source. (Dave Tribby) 6. With static or global integers, multiple assignments of zero (e.g. a=b=0) stored random values in all but the last value. (Doug Gwyn, D.Leffler, AFAAndyW, et. al.) 7. strtod() and related functions fail when the input is a single digit number. (James C.Smith) 8. SaveTextState() in Locator.h did not have an inline directive. (GSPlusDiz) 9. In some cases, successive stores of a long constant with common subexpression elimination turned on would damage the stack. (GNOTim2) 10. Assigning the same constant to both a single-byte value and a word, as in unsigned char foo; unsigned int bar; bar = foo = 1; did not correctly set the most significant byte of the word value. (GNOTim2) 11. In some conditional branches involcing comples integer expressions, the condition code was not properly evaluated. (GNOTim2) 12. Optimization of arithmetic shifts by a constant in the range 9..15 has been improved. (GNOTim2) 13. Closing carriage return added to ToolLib.h. (Doug Gwyn) 14. Some comparisons of pointers to pointers, such as *p1 == *p2, caused the code generator to generate a spurious error. (Soenke Behrens) 15. strtoul() would fail when a string address at the start of a bank was passed. (AFA AndyW) 16. fread() and fwrite() now return results of size_t. (John Joganic) 17. Text programs didn't work when launched from the Finder. (JamesG7858) 18. Run-time error checks for two-byte add and subtract operations flagged legal operations as illegal. Run-time error checks for two-byte adds and subtracts have been removed. (D.Tribby) 19. fclose() did not properly close temp files before trying to destroy them. (Jawaid Bazyar) 20. Decrementing a global or static long by 1 generated incorrect code. This was fixed in an earlier version, but I don't remember which one. (Jawaid Bazyar) 21. The type for ptrdiff_t in stddef.h should be a signed type, not unsigned long. (Doug Gwyn) 22. Using the large memory model, some two-byte load operations used absolute addressing when they should have used long absoule addressing. (AFAAndyW) 23. IBeamCursor() (in QDAux.h) is prototyped with a Word parameter; it should be void. (J.Mills11) 24. TEInsert() (in TextEdit.h) has one too few parameters prototyped. (J.Mills11) 25. Improperly set optionList parameters on GetFileInfo calls were causing compiler crashes, generally in a pseudo-random way, but most often while creating .sym files. (Walker Archer) 26. With optimize 1, adding 1 to a global long and saving the result to the same location generated incorrect code. (e.g. v := v+1 or ++v where v is a global 4-byte value.) 27. The purge call to remove an included file from memory was not working correctly. (Jawaid Bazyar) 28. Casting an l-value is not legal, but the compiler did not flag an error. (Marc Wolfgram, Doug Gwyn) 29. Macro stringization of a string produced a garbage result. (D.Kopper) 30. A conditional jump based on a load of a signed character could be evaluated incorrectly. 31. In several places, particularly in the .CONSOLE standard I/O routines, the libraries used absolute addressing when long addressing should have been used, or when the databank register should have been set to K. These problems could cause loads and stores or loss of character output with the large memory model. (Marsha J, John Joganic, et. al.) 32. The library routine that sets bank zero memory to zero trashes the data register. (GSPlusDiz) 33. gets() does not write a terminating null character if the return key is pressed right away. (Jawaid Bazyar) 34. C programs hang when input is read through standard in and standard in is redirected from a file using a shell command. (Jawaid Bazyar) 35. sys_nerr is 6; it should be 11. (Doug Gwynn, Joe Walters) 36. When a single code segment exceeds 32K, the compiler could loose track of the correct length for an object file. 37. In some cases, a conditional branch based on the result of a divide or add could fail. \ No newline at end of file diff --git a/count b/count new file mode 100755 index 0000000..355aff6 --- /dev/null +++ b/count @@ -0,0 +1 @@ +set list CC.pas set list {list} CCommon.pas set list {list} MM.pas set list {list} Table.pas set list {list} Symbol.pas Symbol.Print set list {list} Scanner.pas Scanner.debug set list {list} Asm.pas set list {list} Expression.pas set list {list} Parser.pas set list {list} CGC.pas set list {list} CGI.pas CGI.Comments CGI.Debug set list {list} ObjOut.pas set list {list} Native.pas set list {list} DAG.pas set list {list} Gen.pas set list {list} Header.pas echo -n "Pascal: " wc -l {list} set list CCommon.asm set list {list} MM.asm set list {list} Table.asm set list {list} Symbol.asm set list {list} Scanner.asm set list {list} Expression.asm set list {list} CGC.asm set list {list} ObjOut.asm set list {list} Native.asm echo -n "Asm: " wc -l {list} set list cc.rez echo -n "Rez: " wc -l {list} \ No newline at end of file diff --git a/linkit b/linkit new file mode 100755 index 0000000..5e833f6 --- /dev/null +++ b/linkit @@ -0,0 +1 @@ +obj/cc obj/symbol obj/parser obj/expression obj/scanner obj/mm obj/ccommon obj/cgi obj/cgc obj/asm obj/table obj/objout obj/native obj/dag obj/gen obj/header keep=16/cc \ No newline at end of file diff --git a/linkit2 b/linkit2 new file mode 100755 index 0000000..f59a57b --- /dev/null +++ b/linkit2 @@ -0,0 +1 @@ +obj/cc obj/symbol obj/parser obj/expression obj/scanner obj/mm obj/ccommon obj/cgi obj/cgc obj/asm obj/table obj/objout2 obj/native2 obj/dag2 obj/gen obj/header2 keep=obj/cc2 \ No newline at end of file diff --git a/make b/make new file mode 100755 index 0000000..cf9345c --- /dev/null +++ b/make @@ -0,0 +1 @@ +unset exit unset cc unset cg Newer 5/cc cc.rez if {status} != 0 set exit on echo compile -e cc.rez keep=5/cc compile -e cc.rez keep=5/cc unset exit end if {#} == 0 Newer obj/asm.a asm.pas if {status} != 0 set asm asm set cc cc set parser parser end Newer obj/cc.a cc.pas if {status} != 0 set cc cc end Newer obj/ccommon.a ccommon.pas ccommon.asm if {Status} != 0 set ccommon ccommon set asm asm set cc cc set cgc cgc set cgi cgi set expression expression set mm mm set parser parser set scanner scanner set symbol symbol set table table set objout objout set native native set dag dag set gen gen set header header end Newer obj/cgc.a cgc.pas cgc.asm if {status} != 0 set cgc cgc set objout objout set native native end Newer obj/cgi.a cgi.pas cgi.comments cgi.debug if {status} != 0 set cgi cgi set asm asm set cc cc set cgc cgc set expression expression set parser parser set scanner scanner set symbol symbol set objout objout set native native set dag dag set header header end Newer obj/expression.a expression.pas expression.asm if {status} != 0 set expression expression set asm asm set cc cc set parser parser end Newer obj/mm.a mm.pas mm.asm if {status} != 0 set mm mm set asm asm set cc cc set expression expression set parser parser set scanner scanner set symbol symbol set header header end Newer obj/native.a native.pas native.asm if {status} != 0 set native native end Newer obj/objout.a objout.pas objout.asm if {status} != 0 set objout objout set native native end Newer obj/parser.a parser.pas if {status} != 0 set parser parser set cc cc end Newer obj/scanner.a scanner.pas scanner.debug scanner.asm if {status} != 0 set scanner scanner set asm asm set cc cc set expression expression set parser parser set symbol symbol set header header end Newer obj/symbol.a symbol.pas symbol.print symbol.asm if {status} != 0 set symbol symbol set asm asm set cc cc set expression expression set parser parser set header header end Newer obj/table.a table.pas table.asm if {status} != 0 set table table set asm asm set expression expression set parser parser set scanner scanner end Newer obj/dag.a dag.pas if {status} != 0 set dag dag end Newer obj/gen.a gen.pas if {status} != 0 set dag dag set gen gen end Newer obj/header.a header.pas if {status} != 0 set cc cc set parser parser set header header end else for i set {i} {i} end end set exit on if "{table}" == table if "{ccommon}" == ccommon echo compile +t +e ccommon.pas keep=obj/ccommon compile +t +e ccommon.pas keep=obj/ccommon unset ccommon end echo compile +t +e table.pas keep=obj/table compile +t +e table.pas keep=obj/table echo assemble +t +e table.asm keep=obj/table assemble +t +e table.asm keep=obj/table echo delete obj/table.root delete obj/table.root end set list "" set list "{ccommon} {mm} {cgi} {scanner} {symbol} {header} {expression}" set list {list} {cgc} {asm} {parser} {cc} {objout} {native} {gen} {dag} if "{list}" != "" for i in {list} echo compile +t +e {i}.pas keep=obj/{i} compile +t +e {i}.pas keep=obj/{i} end end unset exit set exit on compile linkit echo filetype 5/cc exe $DB01 filetype 5/cc exe $DB01 \ No newline at end of file diff --git a/make2 b/make2 new file mode 100755 index 0000000..d72960c --- /dev/null +++ b/make2 @@ -0,0 +1 @@ +unset exit unset cc unset cg Newer obj/cc2 cc.rez2 if {status} != 0 set exit on echo compile -e cc.rez2 keep=obj/cc2 compile -e cc.rez2 keep=obj/cc2 unset exit end if {#} == 0 Newer obj/asm.a asm.pas if {status} != 0 set asm asm set cc cc set parser parser end Newer obj/cc.a cc.pas if {status} != 0 set cc cc end Newer obj/ccommon.a ccommon.pas ccommon.asm if {Status} != 0 set ccommon ccommon set asm asm set cc cc set cgc cgc set cgi cgi set expression expression set mm mm set parser parser set scanner scanner set symbol symbol set table table set objout2 objout2 set native2 native2 set dag2 dag2 set gen gen set header2 header2 end Newer obj/cgc.a cgc.pas cgc.asm if {status} != 0 set cgc cgc set objout2 objout2 set native2 native2 end Newer obj/cgi.a cgi.pas cgi.comments cgi.debug if {status} != 0 set cgi cgi set asm asm set cc cc set cgc cgc set expression expression set parser parser set scanner scanner set symbol symbol set objout2 objout2 set native2 native2 set dag2 dag2 set header2 header2 end Newer obj/expression.a expression.pas expression.asm if {status} != 0 set expression expression set asm asm set cc cc set parser parser end Newer obj/mm.a mm.pas mm.asm if {status} != 0 set mm mm set asm asm set cc cc set expression expression set parser parser set scanner scanner set symbol symbol set header2 header2 end Newer obj/native2.a native2.pas if {status} != 0 set native2 native2 end Newer obj/objout2.a objout2.pas objout2.asm if {status} != 0 set objout2 objout2 set native2 native2 end Newer obj/parser.a parser.pas if {status} != 0 set parser parser set cc cc end Newer obj/scanner.a scanner.pas scanner.debug scanner.asm if {status} != 0 set scanner scanner set asm asm set cc cc set expression expression set parser parser set symbol symbol set header2 header2 end Newer obj/symbol.a symbol.pas symbol.print symbol.asm if {status} != 0 set symbol symbol set asm asm set cc cc set expression expression set parser parser set header2 header2 end Newer obj/table.a table.pas table.asm if {status} != 0 set table table set asm asm set expression expression set parser parser set scanner scanner end Newer obj/dag2.a dag2.pas if {status} != 0 set dag2 dag2 end Newer obj/gen.a gen.pas if {status} != 0 set dag2 dag2 set gen gen end Newer obj/header2.a header2.pas if {status} != 0 set cc cc set parser parser set header2 header2 end else for i set {i} {i} end end set exit on if "{table}" == table if "{ccommon}" == ccommon echo compile +t +e ccommon.pas keep=obj/ccommon compile +t +e ccommon.pas keep=obj/ccommon unset ccommon end echo compile +t +e table.pas keep=obj/table compile +t +e table.pas keep=obj/table echo assemble +t +e table.asm keep=obj/table assemble +t +e table.asm keep=obj/table echo delete obj/table.root delete obj/table.root end set list "" set list "{ccommon} {mm} {cgi} {scanner} {symbol} {header2} {expression}" set list {list} {cgc} {asm} {parser} {cc} {objout2} {native2} {gen} {dag2} if "{list}" != "" for i in {list} echo compile +t +e {i}.pas keep=obj/{i} compile +t +e {i}.pas keep=obj/{i} end end unset exit set exit on compile linkit2 echo filetype obj/cc2 exe $DB01 filetype obj/cc2 exe $DB01 * echo purge * purge >.null \ No newline at end of file diff --git a/obj/README.txt b/obj/README.txt new file mode 100644 index 0000000..e1e1427 --- /dev/null +++ b/obj/README.txt @@ -0,0 +1 @@ +This directory is used by the make file for storing object files. \ No newline at end of file diff --git a/smake b/smake new file mode 100755 index 0000000..53fe5c7 --- /dev/null +++ b/smake @@ -0,0 +1 @@ +unset exit unset cc unset cg Newer 5/cc cc.rez if {status} != 0 set exit on echo compile -e cc.rez keep=5/cc compile -e cc.rez keep=5/cc unset exit end if {#} == 0 Newer obj/asm.a asm.pas if {status} != 0 set asm asm set cc cc set parser parser end Newer obj/cc.a cc.pas if {status} != 0 set cc cc end Newer obj/ccommon.a ccommon.pas ccommon.asm if {Status} != 0 set ccommon ccommon set asm asm set cc cc set cgc cgc set cgi cgi set expression expression set mm mm set parser parser set scanner scanner set symbol symbol set table table set objout2 objout2 set native2 native2 set dag2 dag2 set gen gen set header2 header2 end Newer obj/cgc.a cgc.pas cgc.asm if {status} != 0 set cgc cgc set objout2 objout2 set native2 native2 end Newer obj/cgi.a cgi.pas cgi.comments cgi.debug if {status} != 0 set cgi cgi set asm asm set cc cc set cgc cgc set expression expression set parser parser set scanner scanner set symbol symbol set objout2 objout2 set native2 native2 set dag2 dag2 set header2 header2 end Newer obj/expression.a expression.pas expression.asm if {status} != 0 set expression expression set asm asm set cc cc set parser parser end Newer obj/mm.a mm.pas mm.asm if {status} != 0 set mm mm set asm asm set cc cc set expression expression set parser parser set scanner scanner set symbol symbol set header2 header2 end Newer obj/native2.a native2.pas if {status} != 0 set native2 native2 end Newer obj/objout2.a objout2.pas objout2.asm if {status} != 0 set objout2 objout2 set native2 native2 end Newer obj/parser.a parser.pas if {status} != 0 set parser parser set cc cc end Newer obj/scanner.a scanner.pas scanner.debug scanner.asm if {status} != 0 set scanner scanner set asm asm set cc cc set expression expression set parser parser set symbol symbol set header2 header2 end Newer obj/symbol.a symbol.pas symbol.print symbol.asm if {status} != 0 set symbol symbol set asm asm set cc cc set expression expression set parser parser set header2 header2 end Newer obj/table.a table.pas table.asm if {status} != 0 set table table set asm asm set expression expression set parser parser set scanner scanner end Newer obj/dag2.a dag2.pas if {status} != 0 set dag2 dag2 end Newer obj/gen.a gen.pas if {status} != 0 set dag2 dag2 set gen gen end Newer obj/header2.a header2.pas if {status} != 0 set cc cc set parser parser set header2 header2 end else for i set {i} {i} end end set exit on if "{table}" == table if "{ccommon}" == ccommon echo compile +t +e ccommon.pas keep=obj/ccommon compile +t +e ccommon.pas keep=obj/ccommon unset ccommon end echo compile +t +e table.pas keep=obj/table compile +t +e table.pas keep=obj/table echo assemble +t +e table.asm keep=obj/table assemble +t +e table.asm keep=obj/table echo delete obj/table.root delete obj/table.root end set list "" set list "{ccommon} {mm} {cgi} {scanner} {symbol} {header2} {expression}" set list {list} {cgc} {asm} {parser} {cc} {objout2} {native2} {gen} {dag2} if "{list}" != "" for i in {list} purge >.null echo compile +t +e {i}.pas keep=obj/{i} compile +t +e {i}.pas keep=obj/{i} end end unset exit set exit on compile linkit2 echo filetype 5/cc exe $DB01 filetype 5/cc exe $DB01 echo purge purge >.null \ No newline at end of file