* synchronized with trunk

git-svn-id: branches/wasm@47463 -

.gitattributes

@@ -4358,14 +4358,34 @@ packages/fcl-sound/src/fpwavreader.pas svneol=native#text/plain
 packages/fcl-sound/src/fpwavwriter.pas svneol=native#text/plain
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_16.wav -text svneol=unset#audio/x-wav
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_16.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_16.wav.raw -text
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_16_tag.wav -text svneol=unset#audio/x-wav
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_16_tag.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_16_tag.wav.raw -text
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_24.wav -text svneol=unset#audio/x-wav
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_24.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_24.wav.raw -text
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_32.wav -text svneol=unset#audio/x-wav
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_32.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_32.wav.raw -text
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_8.wav -text svneol=unset#audio/x-wav
 packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_8.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_8.wav.raw -text svneol=unset#application/octet-stream
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_16.wav -text svneol=unset#audio/x-wav
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_16.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_16.wav.raw -text
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_24.wav -text svneol=unset#audio/x-wav
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_24.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_24.wav.raw -text
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_32.wav -text svneol=unset#audio/x-wav
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_32.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_32.wav.raw -text
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_8.wav -text svneol=unset#audio/x-wav
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_8.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_8.wav.raw -text svneol=unset#application/octet-stream
+packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav -text svneol=unset#audio/x-wav
+packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav.info.txt svneol=native#text/plain
+packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav.raw -text svneol=unset#application/octet-stream
 packages/fcl-sound/tests/tcwavreader.pas svneol=native#text/plain
 packages/fcl-sound/tests/testfclsound.lpi svneol=native#text/plain
 packages/fcl-sound/tests/testfclsound.lpr svneol=native#text/plain
@@ -8743,8 +8763,10 @@ packages/pxlib/src/pxlib.pp svneol=native#text/plain
 packages/qlunits/Makefile svneol=native#text/plain
 packages/qlunits/Makefile.fpc svneol=native#text/plain
 packages/qlunits/README.txt svneol=native#text/plain
+packages/qlunits/examples/qlcube.pas svneol=native#text/plain
 packages/qlunits/fpmake.pp svneol=native#text/plain
 packages/qlunits/src/qdos.pas svneol=native#text/plain
+packages/qlunits/src/qlfloat.pas svneol=native#text/plain
 packages/regexpr/Makefile svneol=native#text/plain
 packages/regexpr/Makefile.fpc svneol=native#text/plain
 packages/regexpr/Makefile.fpc.fpcmake svneol=native#text/plain

compiler/ninl.pas

@@ -868,7 +868,10 @@ implementation
                   end;
                 end;
               variantdef :
-                name:=procprefixes[do_read]+'variant';
+                begin
+                  name:=procprefixes[do_read]+'variant';
+                  include(current_module.moduleflags,mf_uses_variants);
+                end;
               arraydef :
                 begin
                   if is_chararray(para.left.resultdef) then

packages/fcl-sound/src/fpwavformat.pas

@@ -25,6 +25,275 @@ const
   AUDIO_CHUNK_ID_fmt  = 'fmt ';
   AUDIO_CHUNK_ID_data = 'data';
   AUDIO_FORMAT_PCM = 1;
+  
+  { WAVE form wFormatTag IDs }
+  WAVE_FORMAT_UNKNOWN                    = $0000; { Microsoft Corporation }
+  WAVE_FORMAT_PCM                        = $0001; { Microsoft Corporation }
+  WAVE_FORMAT_ADPCM                      = $0002; { Microsoft Corporation }
+  WAVE_FORMAT_IEEE_FLOAT                 = $0003; { Microsoft Corporation }
+  WAVE_FORMAT_VSELP                      = $0004; { Compaq Computer Corp. }
+  WAVE_FORMAT_IBM_CVSD                   = $0005; { IBM Corporation }
+  WAVE_FORMAT_ALAW                       = $0006; { Microsoft Corporation }
+  WAVE_FORMAT_MULAW                      = $0007; { Microsoft Corporation }
+  WAVE_FORMAT_DTS                        = $0008; { Microsoft Corporation }
+  WAVE_FORMAT_DRM                        = $0009; { Microsoft Corporation }
+  WAVE_FORMAT_WMAVOICE9                  = $000A; { Microsoft Corporation }
+  WAVE_FORMAT_WMAVOICE10                 = $000B; { Microsoft Corporation }
+  WAVE_FORMAT_OKI_ADPCM                  = $0010; { OKI }
+  WAVE_FORMAT_DVI_ADPCM                  = $0011; { Intel Corporation }
+  WAVE_FORMAT_IMA_ADPCM                  = (WAVE_FORMAT_DVI_ADPCM); {  Intel Corporation }
+  WAVE_FORMAT_MEDIASPACE_ADPCM           = $0012; { Videologic }
+  WAVE_FORMAT_SIERRA_ADPCM               = $0013; { Sierra Semiconductor Corp }
+  WAVE_FORMAT_G723_ADPCM                 = $0014; { Antex Electronics Corporation }
+  WAVE_FORMAT_DIGISTD                    = $0015; { DSP Solutions, Inc. }
+  WAVE_FORMAT_DIGIFIX                    = $0016; { DSP Solutions, Inc. }
+  WAVE_FORMAT_DIALOGIC_OKI_ADPCM         = $0017; { Dialogic Corporation }
+  WAVE_FORMAT_MEDIAVISION_ADPCM          = $0018; { Media Vision, Inc. }
+  WAVE_FORMAT_CU_CODEC                   = $0019; { Hewlett-Packard Company }
+  WAVE_FORMAT_HP_DYN_VOICE               = $001A; { Hewlett-Packard Company }
+  WAVE_FORMAT_YAMAHA_ADPCM               = $0020; { Yamaha Corporation of America }
+  WAVE_FORMAT_SONARC                     = $0021; { Speech Compression }
+  WAVE_FORMAT_DSPGROUP_TRUESPEECH        = $0022; { DSP Group, Inc }
+  WAVE_FORMAT_ECHOSC1                    = $0023; { Echo Speech Corporation }
+  WAVE_FORMAT_AUDIOFILE_AF36             = $0024; { Virtual Music, Inc. }
+  WAVE_FORMAT_APTX                       = $0025; { Audio Processing Technology }
+  WAVE_FORMAT_AUDIOFILE_AF10             = $0026; { Virtual Music, Inc. }
+  WAVE_FORMAT_PROSODY_1612               = $0027; { Aculab plc }
+  WAVE_FORMAT_LRC                        = $0028; { Merging Technologies S.A. }
+  WAVE_FORMAT_DOLBY_AC2                  = $0030; { Dolby Laboratories }
+  WAVE_FORMAT_GSM610                     = $0031; { Microsoft Corporation }
+  WAVE_FORMAT_MSNAUDIO                   = $0032; { Microsoft Corporation }
+  WAVE_FORMAT_ANTEX_ADPCME               = $0033; { Antex Electronics Corporation }
+  WAVE_FORMAT_CONTROL_RES_VQLPC          = $0034; { Control Resources Limited }
+  WAVE_FORMAT_DIGIREAL                   = $0035; { DSP Solutions, Inc. }
+  WAVE_FORMAT_DIGIADPCM                  = $0036; { DSP Solutions, Inc. }
+  WAVE_FORMAT_CONTROL_RES_CR10           = $0037; { Control Resources Limited }
+  WAVE_FORMAT_NMS_VBXADPCM               = $0038; { Natural MicroSystems }
+  WAVE_FORMAT_CS_IMAADPCM                = $0039; { Crystal Semiconductor IMA ADPCM }
+  WAVE_FORMAT_ECHOSC3                    = $003A; { Echo Speech Corporation }
+  WAVE_FORMAT_ROCKWELL_ADPCM             = $003B; { Rockwell International }
+  WAVE_FORMAT_ROCKWELL_DIGITALK          = $003C; { Rockwell International }
+  WAVE_FORMAT_XEBEC                      = $003D; { Xebec Multimedia Solutions Limited }
+  WAVE_FORMAT_G721_ADPCM                 = $0040; { Antex Electronics Corporation }
+  WAVE_FORMAT_G728_CELP                  = $0041; { Antex Electronics Corporation }
+  WAVE_FORMAT_MSG723                     = $0042; { Microsoft Corporation }
+  WAVE_FORMAT_INTEL_G723_1               = $0043; { Intel Corp. }
+  WAVE_FORMAT_INTEL_G729                 = $0044; { Intel Corp. }
+  WAVE_FORMAT_SHARP_G726                 = $0045; { Sharp }
+  WAVE_FORMAT_MPEG                       = $0050; { Microsoft Corporation }
+  WAVE_FORMAT_RT24                       = $0052; { InSoft, Inc. }
+  WAVE_FORMAT_PAC                        = $0053; { InSoft, Inc. }
+  WAVE_FORMAT_MPEGLAYER3                 = $0055; { ISO/MPEG Layer3 Format Tag }
+  WAVE_FORMAT_LUCENT_G723                = $0059; { Lucent Technologies }
+  WAVE_FORMAT_CIRRUS                     = $0060; { Cirrus Logic }
+  WAVE_FORMAT_ESPCM                      = $0061; { ESS Technology }
+  WAVE_FORMAT_VOXWARE                    = $0062; { Voxware Inc }
+  WAVE_FORMAT_CANOPUS_ATRAC              = $0063; { Canopus, co., Ltd. }
+  WAVE_FORMAT_G726_ADPCM                 = $0064; { APICOM }
+  WAVE_FORMAT_G722_ADPCM                 = $0065; { APICOM }
+  WAVE_FORMAT_DSAT                       = $0066; { Microsoft Corporation }
+  WAVE_FORMAT_DSAT_DISPLAY               = $0067; { Microsoft Corporation }
+  WAVE_FORMAT_VOXWARE_BYTE_ALIGNED       = $0069; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_AC8                = $0070; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_AC10               = $0071; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_AC16               = $0072; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_AC20               = $0073; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_RT24               = $0074; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_RT29               = $0075; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_RT29HW             = $0076; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_VR12               = $0077; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_VR18               = $0078; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_TQ40               = $0079; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_SC3                = $007A; { Voxware Inc }
+  WAVE_FORMAT_VOXWARE_SC3_1              = $007B; { Voxware Inc }
+  WAVE_FORMAT_SOFTSOUND                  = $0080; { Softsound, Ltd. }
+  WAVE_FORMAT_VOXWARE_TQ60               = $0081; { Voxware Inc }
+  WAVE_FORMAT_MSRT24                     = $0082; { Microsoft Corporation }
+  WAVE_FORMAT_G729A                      = $0083; { AT&T Labs, Inc. }
+  WAVE_FORMAT_MVI_MVI2                   = $0084; { Motion Pixels }
+  WAVE_FORMAT_DF_G726                    = $0085; { DataFusion Systems (Pty) (Ltd) }
+  WAVE_FORMAT_DF_GSM610                  = $0086; { DataFusion Systems (Pty) (Ltd) }
+  WAVE_FORMAT_ISIAUDIO                   = $0088; { Iterated Systems, Inc. }
+  WAVE_FORMAT_ONLIVE                     = $0089; { OnLive! Technologies, Inc. }
+  WAVE_FORMAT_MULTITUDE_FT_SX20          = $008A; { Multitude Inc. }
+  WAVE_FORMAT_INFOCOM_ITS_G721_ADPCM     = $008B; { Infocom }
+  WAVE_FORMAT_CONVEDIA_G729              = $008C; { Convedia Corp. }
+  WAVE_FORMAT_CONGRUENCY                 = $008D; { Congruency Inc. }
+  WAVE_FORMAT_SBC24                      = $0091; { Siemens Business Communications Sys }
+  WAVE_FORMAT_DOLBY_AC3_SPDIF            = $0092; { Sonic Foundry }
+  WAVE_FORMAT_MEDIASONIC_G723            = $0093; { MediaSonic }
+  WAVE_FORMAT_PROSODY_8KBPS              = $0094; { Aculab plc }
+  WAVE_FORMAT_ZYXEL_ADPCM                = $0097; { ZyXEL Communications, Inc. }
+  WAVE_FORMAT_PHILIPS_LPCBB              = $0098; { Philips Speech Processing }
+  WAVE_FORMAT_PACKED                     = $0099; { Studer Professional Audio AG }
+  WAVE_FORMAT_MALDEN_PHONYTALK           = $00A0; { Malden Electronics Ltd. }
+  WAVE_FORMAT_RACAL_RECORDER_GSM         = $00A1; { Racal recorders }
+  WAVE_FORMAT_RACAL_RECORDER_G720_A      = $00A2; { Racal recorders }
+  WAVE_FORMAT_RACAL_RECORDER_G723_1      = $00A3; { Racal recorders }
+  WAVE_FORMAT_RACAL_RECORDER_TETRA_ACELP = $00A4; { Racal recorders }
+  WAVE_FORMAT_NEC_AAC                    = $00B0; { NEC Corp. }
+  WAVE_FORMAT_RAW_AAC1                   = $00FF; { For Raw AAC, with format block AudioSpecificConfig() (as defined by MPEG-4), that follows WAVEFORMATEX }
+  WAVE_FORMAT_RHETOREX_ADPCM             = $0100; { Rhetorex Inc. }
+  WAVE_FORMAT_IRAT                       = $0101; { BeCubed Software Inc. }
+  WAVE_FORMAT_VIVO_G723                  = $0111; { Vivo Software }
+  WAVE_FORMAT_VIVO_SIREN                 = $0112; { Vivo Software }
+  WAVE_FORMAT_PHILIPS_CELP               = $0120; { Philips Speech Processing }
+  WAVE_FORMAT_PHILIPS_GRUNDIG            = $0121; { Philips Speech Processing }
+  WAVE_FORMAT_DIGITAL_G723               = $0123; { Digital Equipment Corporation }
+  WAVE_FORMAT_SANYO_LD_ADPCM             = $0125; { Sanyo Electric Co., Ltd. }
+  WAVE_FORMAT_SIPROLAB_ACEPLNET          = $0130; { Sipro Lab Telecom Inc. }
+  WAVE_FORMAT_SIPROLAB_ACELP4800         = $0131; { Sipro Lab Telecom Inc. }
+  WAVE_FORMAT_SIPROLAB_ACELP8V3          = $0132; { Sipro Lab Telecom Inc. }
+  WAVE_FORMAT_SIPROLAB_G729              = $0133; { Sipro Lab Telecom Inc. }
+  WAVE_FORMAT_SIPROLAB_G729A             = $0134; { Sipro Lab Telecom Inc. }
+  WAVE_FORMAT_SIPROLAB_KELVIN            = $0135; { Sipro Lab Telecom Inc. }
+  WAVE_FORMAT_VOICEAGE_AMR               = $0136; { VoiceAge Corp. }
+  WAVE_FORMAT_G726ADPCM                  = $0140; { Dictaphone Corporation }
+  WAVE_FORMAT_DICTAPHONE_CELP68          = $0141; { Dictaphone Corporation }
+  WAVE_FORMAT_DICTAPHONE_CELP54          = $0142; { Dictaphone Corporation }
+  WAVE_FORMAT_QUALCOMM_PUREVOICE         = $0150; { Qualcomm, Inc. }
+  WAVE_FORMAT_QUALCOMM_HALFRATE          = $0151; { Qualcomm, Inc. }
+  WAVE_FORMAT_TUBGSM                     = $0155; { Ring Zero Systems, Inc. }
+  WAVE_FORMAT_MSAUDIO1                   = $0160; { Microsoft Corporation }
+  WAVE_FORMAT_WMAUDIO2                   = $0161; { Microsoft Corporation }
+  WAVE_FORMAT_WMAUDIO3                   = $0162; { Microsoft Corporation }
+  WAVE_FORMAT_WMAUDIO_LOSSLESS           = $0163; { Microsoft Corporation }
+  WAVE_FORMAT_WMASPDIF                   = $0164; { Microsoft Corporation }
+  WAVE_FORMAT_UNISYS_NAP_ADPCM           = $0170; { Unisys Corp. }
+  WAVE_FORMAT_UNISYS_NAP_ULAW            = $0171; { Unisys Corp. }
+  WAVE_FORMAT_UNISYS_NAP_ALAW            = $0172; { Unisys Corp. }
+  WAVE_FORMAT_UNISYS_NAP_16K             = $0173; { Unisys Corp. }
+  WAVE_FORMAT_SYCOM_ACM_SYC008           = $0174; { SyCom Technologies }
+  WAVE_FORMAT_SYCOM_ACM_SYC701_G726L     = $0175; { SyCom Technologies }
+  WAVE_FORMAT_SYCOM_ACM_SYC701_CELP54    = $0176; { SyCom Technologies }
+  WAVE_FORMAT_SYCOM_ACM_SYC701_CELP68    = $0177; { SyCom Technologies }
+  WAVE_FORMAT_KNOWLEDGE_ADVENTURE_ADPCM  = $0178; { Knowledge Adventure, Inc. }
+  WAVE_FORMAT_FRAUNHOFER_IIS_MPEG2_AAC   = $0180; { Fraunhofer IIS }
+  WAVE_FORMAT_DTS_DS                     = $0190; { Digital Theatre Systems, Inc. }
+  WAVE_FORMAT_CREATIVE_ADPCM             = $0200; { Creative Labs, Inc }
+  WAVE_FORMAT_CREATIVE_FASTSPEECH8       = $0202; { Creative Labs, Inc }
+  WAVE_FORMAT_CREATIVE_FASTSPEECH10      = $0203; { Creative Labs, Inc }
+  WAVE_FORMAT_UHER_ADPCM                 = $0210; { UHER informatic GmbH }
+  WAVE_FORMAT_ULEAD_DV_AUDIO             = $0215; { Ulead Systems, Inc. }
+  WAVE_FORMAT_ULEAD_DV_AUDIO_1           = $0216; { Ulead Systems, Inc. }
+  WAVE_FORMAT_QUARTERDECK                = $0220; { Quarterdeck Corporation }
+  WAVE_FORMAT_ILINK_VC                   = $0230; { I-link Worldwide }
+  WAVE_FORMAT_RAW_SPORT                  = $0240; { Aureal Semiconductor }
+  WAVE_FORMAT_ESST_AC3                   = $0241; { ESS Technology, Inc. }
+  WAVE_FORMAT_GENERIC_PASSTHRU           = $0249;
+  WAVE_FORMAT_IPI_HSX                    = $0250; { Interactive Products, Inc. }
+  WAVE_FORMAT_IPI_RPELP                  = $0251; { Interactive Products, Inc. }
+  WAVE_FORMAT_CS2                        = $0260; { Consistent Software }
+  WAVE_FORMAT_SONY_SCX                   = $0270; { Sony Corp. }
+  WAVE_FORMAT_SONY_SCY                   = $0271; { Sony Corp. }
+  WAVE_FORMAT_SONY_ATRAC3                = $0272; { Sony Corp. }
+  WAVE_FORMAT_SONY_SPC                   = $0273; { Sony Corp. }
+  WAVE_FORMAT_TELUM_AUDIO                = $0280; { Telum Inc. }
+  WAVE_FORMAT_TELUM_IA_AUDIO             = $0281; { Telum Inc. }
+  WAVE_FORMAT_NORCOM_VOICE_SYSTEMS_ADPCM = $0285; { Norcom Electronics Corp. }
+  WAVE_FORMAT_FM_TOWNS_SND               = $0300; { Fujitsu Corp. }
+  WAVE_FORMAT_MICRONAS                   = $0350; { Micronas Semiconductors, Inc. }
+  WAVE_FORMAT_MICRONAS_CELP833           = $0351; { Micronas Semiconductors, Inc. }
+  WAVE_FORMAT_BTV_DIGITAL                = $0400; { Brooktree Corporation }
+  WAVE_FORMAT_INTEL_MUSIC_CODER          = $0401; { Intel Corp. }
+  WAVE_FORMAT_INDEO_AUDIO                = $0402; { Ligos }
+  WAVE_FORMAT_QDESIGN_MUSIC              = $0450; { QDesign Corporation }
+  WAVE_FORMAT_ON2_VP7_AUDIO              = $0500; { On2 Technologies }
+  WAVE_FORMAT_ON2_VP6_AUDIO              = $0501; { On2 Technologies }
+  WAVE_FORMAT_VME_VMPCM                  = $0680; { AT&T Labs, Inc. }
+  WAVE_FORMAT_TPC                        = $0681; { AT&T Labs, Inc. }
+  WAVE_FORMAT_LIGHTWAVE_LOSSLESS         = $08AE; { Clearjump }
+  WAVE_FORMAT_OLIGSM                     = $1000; { Ing C. Olivetti & C., S.p.A. }
+  WAVE_FORMAT_OLIADPCM                   = $1001; { Ing C. Olivetti & C., S.p.A. }
+  WAVE_FORMAT_OLICELP                    = $1002; { Ing C. Olivetti & C., S.p.A. }
+  WAVE_FORMAT_OLISBC                     = $1003; { Ing C. Olivetti & C., S.p.A. }
+  WAVE_FORMAT_OLIOPR                     = $1004; { Ing C. Olivetti & C., S.p.A. }
+  WAVE_FORMAT_LH_CODEC                   = $1100; { Lernout & Hauspie }
+  WAVE_FORMAT_LH_CODEC_CELP              = $1101; { Lernout & Hauspie }
+  WAVE_FORMAT_LH_CODEC_SBC8              = $1102; { Lernout & Hauspie }
+  WAVE_FORMAT_LH_CODEC_SBC12             = $1103; { Lernout & Hauspie }
+  WAVE_FORMAT_LH_CODEC_SBC16             = $1104; { Lernout & Hauspie }
+  WAVE_FORMAT_NORRIS                     = $1400; { Norris Communications, Inc. }
+  WAVE_FORMAT_ISIAUDIO_2                 = $1401; { ISIAudio }
+  WAVE_FORMAT_SOUNDSPACE_MUSICOMPRESS    = $1500; { AT&T Labs, Inc. }
+  WAVE_FORMAT_MPEG_ADTS_AAC              = $1600; { Microsoft Corporation }
+  WAVE_FORMAT_MPEG_RAW_AAC               = $1601; { Microsoft Corporation }
+  WAVE_FORMAT_MPEG_LOAS                  = $1602; { Microsoft Corporation (MPEG-4 Audio Transport Streams (LOAS/LATM) }
+  WAVE_FORMAT_NOKIA_MPEG_ADTS_AAC        = $1608; { Microsoft Corporation }
+  WAVE_FORMAT_NOKIA_MPEG_RAW_AAC         = $1609; { Microsoft Corporation }
+  WAVE_FORMAT_VODAFONE_MPEG_ADTS_AAC     = $160A; { Microsoft Corporation }
+  WAVE_FORMAT_VODAFONE_MPEG_RAW_AAC      = $160B; { Microsoft Corporation }
+  WAVE_FORMAT_MPEG_HEAAC                 = $1610; { Microsoft Corporation (MPEG-2 AAC or MPEG-4 HE-AAC v1/v2 streams with any payload (ADTS, ADIF, LOAS/LATM, RAW). Format block includes MP4 AudioSpecificConfig() -- see HEAACWAVEFORMAT below }
+  WAVE_FORMAT_VOXWARE_RT24_SPEECH        = $181C; { Voxware Inc. }
+  WAVE_FORMAT_SONICFOUNDRY_LOSSLESS      = $1971; { Sonic Foundry }
+  WAVE_FORMAT_INNINGS_TELECOM_ADPCM      = $1979; { Innings Telecom Inc. }
+  WAVE_FORMAT_LUCENT_SX8300P             = $1C07; { Lucent Technologies }
+  WAVE_FORMAT_LUCENT_SX5363S             = $1C0C; { Lucent Technologies }
+  WAVE_FORMAT_CUSEEME                    = $1F03; { CUSeeMe }
+  WAVE_FORMAT_NTCSOFT_ALF2CM_ACM         = $1FC4; { NTCSoft }
+  WAVE_FORMAT_DVM                        = $2000; { FAST Multimedia AG }
+  WAVE_FORMAT_DTS2                       = $2001;
+  WAVE_FORMAT_MAKEAVIS                   = $3313;
+  WAVE_FORMAT_DIVIO_MPEG4_AAC            = $4143; { Divio, Inc. }
+  WAVE_FORMAT_NOKIA_ADAPTIVE_MULTIRATE   = $4201; { Nokia }
+  WAVE_FORMAT_DIVIO_G726                 = $4243; { Divio, Inc. }
+  WAVE_FORMAT_LEAD_SPEECH                = $434C; { LEAD Technologies }
+  WAVE_FORMAT_LEAD_VORBIS                = $564C; { LEAD Technologies }
+  WAVE_FORMAT_WAVPACK_AUDIO              = $5756; { xiph.org }
+  WAVE_FORMAT_ALAC                       = $6C61; { Apple Lossless }
+  WAVE_FORMAT_OGG_VORBIS_MODE_1          = $674F; { Ogg Vorbis }
+  WAVE_FORMAT_OGG_VORBIS_MODE_2          = $6750; { Ogg Vorbis }
+  WAVE_FORMAT_OGG_VORBIS_MODE_3          = $6751; { Ogg Vorbis }
+  WAVE_FORMAT_OGG_VORBIS_MODE_1_PLUS     = $676F; { Ogg Vorbis }
+  WAVE_FORMAT_OGG_VORBIS_MODE_2_PLUS     = $6770; { Ogg Vorbis }
+  WAVE_FORMAT_OGG_VORBIS_MODE_3_PLUS     = $6771; { Ogg Vorbis }
+  WAVE_FORMAT_3COM_NBX                   = $7000; { 3COM Corp. }
+  WAVE_FORMAT_OPUS                       = $704F; { Opus }
+  WAVE_FORMAT_FAAD_AAC                   = $706D;
+  WAVE_FORMAT_AMR_NB                     = $7361; { AMR Narrowband }
+  WAVE_FORMAT_AMR_WB                     = $7362; { AMR Wideband }
+  WAVE_FORMAT_AMR_WP                     = $7363; { AMR Wideband Plus }
+  WAVE_FORMAT_GSM_AMR_CBR                = $7A21; { GSMA/3GPP }
+  WAVE_FORMAT_GSM_AMR_VBR_SID            = $7A22; { GSMA/3GPP }
+  WAVE_FORMAT_COMVERSE_INFOSYS_G723_1    = $A100; { Comverse Infosys }
+  WAVE_FORMAT_COMVERSE_INFOSYS_AVQSBC    = $A101; { Comverse Infosys }
+  WAVE_FORMAT_COMVERSE_INFOSYS_SBC       = $A102; { Comverse Infosys }
+  WAVE_FORMAT_SYMBOL_G729_A              = $A103; { Symbol Technologies }
+  WAVE_FORMAT_VOICEAGE_AMR_WB            = $A104; { VoiceAge Corp. }
+  WAVE_FORMAT_INGENIENT_G726             = $A105; { Ingenient Technologies, Inc. }
+  WAVE_FORMAT_MPEG4_AAC                  = $A106; { ISO/MPEG-4 }
+  WAVE_FORMAT_ENCORE_G726                = $A107; { Encore Software }
+  WAVE_FORMAT_ZOLL_ASAO                  = $A108; { ZOLL Medical Corp. }
+  WAVE_FORMAT_SPEEX_VOICE                = $A109; { xiph.org }
+  WAVE_FORMAT_VIANIX_MASC                = $A10A; { Vianix LLC }
+  WAVE_FORMAT_WM9_SPECTRUM_ANALYZER      = $A10B; { Microsoft }
+  WAVE_FORMAT_WMF_SPECTRUM_ANAYZER       = $A10C; { Microsoft }
+  WAVE_FORMAT_GSM_610                    = $A10D;
+  WAVE_FORMAT_GSM_620                    = $A10E;
+  WAVE_FORMAT_GSM_660                    = $A10F;
+  WAVE_FORMAT_GSM_690                    = $A110;
+  WAVE_FORMAT_GSM_ADAPTIVE_MULTIRATE_WB  = $A111;
+  WAVE_FORMAT_POLYCOM_G722               = $A112; { Polycom }
+  WAVE_FORMAT_POLYCOM_G728               = $A113; { Polycom }
+  WAVE_FORMAT_POLYCOM_G729_A             = $A114; { Polycom }
+  WAVE_FORMAT_POLYCOM_SIREN              = $A115; { Polycom }
+  WAVE_FORMAT_GLOBAL_IP_ILBC             = $A116; { Global IP }
+  WAVE_FORMAT_RADIOTIME_TIME_SHIFT_RADIO = $A117; { RadioTime }
+  WAVE_FORMAT_NICE_ACA                   = $A118; { Nice Systems }
+  WAVE_FORMAT_NICE_ADPCM                 = $A119; { Nice Systems }
+  WAVE_FORMAT_VOCORD_G721                = $A11A; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_G726                = $A11B; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_G722_1              = $A11C; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_G728                = $A11D; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_G729                = $A11E; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_G729_A              = $A11F; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_G723_1              = $A120; { Vocord Telecom }
+  WAVE_FORMAT_VOCORD_LBC                 = $A121; { Vocord Telecom }
+  WAVE_FORMAT_NICE_G728                  = $A122; { Nice Systems }
+  WAVE_FORMAT_FRACE_TELECOM_G729         = $A123; { France Telecom }
+  WAVE_FORMAT_CODIAN                     = $A124; { CODIAN }
+  WAVE_FORMAT_FLAC                       = $F1AC; { flac.sourceforge.net }
+  WAVE_FORMAT_EXTENSIBLE                 = $FFFE; { Microsoft }
 
 type
   TChunkID = array [0..3] of char;

packages/fcl-sound/src/fpwavreader.pas

@@ -94,7 +94,9 @@ begin
   Result := Result and (riff.ChunkHeader.ID = AUDIO_CHUNK_ID_RIFF) and (riff.Format = AUDIO_CHUNK_ID_WAVE);
   Result := Result and (fStream.Read(fmt, sizeof(fmt)) = sizeof(fmt));
   LEtoN(fmt);
-  Result := Result and (fmt.ChunkHeader.ID = AUDIO_CHUNK_ID_fmt);
+  Result := Result and (fmt.ChunkHeader.ID = AUDIO_CHUNK_ID_fmt) and ((fmt.ChunkHeader.Size + 8) >= sizeof(fmt));
+  if Result and ((fmt.ChunkHeader.Size + 8) > sizeof(fmt)) then
+    fStream.Seek((fmt.ChunkHeader.Size + 8) - sizeof(fmt), soCurrent);
   if Result and (fmt.Format <> 1) then 
     Exit(False);
 end;

packages/fcl-sound/tests/data/wav/reader/valid/44k_mono_8.wav.raw

@@ -0,0 +1 @@
+唽摍煡�祷棵撬涡矣栽右型势陆繁�潟巻wpic\WRNKHGFFGILOTY^djqx~厠憱殲。ゥぃ�殩拲垉~zvromlkklmoqsvy|

packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_16.wav.info.txt

@@ -0,0 +1 @@
+44100 2 16

packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_24.wav.info.txt

@@ -0,0 +1 @@
+44100 2 24

packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_32.wav.info.txt

@@ -0,0 +1 @@
+44100 2 32

packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_8.wav.info.txt

@@ -0,0 +1 @@
+44100 2 8

packages/fcl-sound/tests/data/wav/reader/valid/44k_stereo_8.wav.raw

@@ -0,0 +1 @@
+�n蒒𦧺法綏驥胵跩跣跧跫輆輀輇輋����������������輋庬膺郡俽箒}ema]]MZ>X1V%TSRRSTUWZ]aei(m4rBwP{_�n���𣑐俈尐𠳔␋羽來肴皇倔晉紕紡挈悄���址山】萜𢬎㛇𤉶𩤅䕭𨅝䱗������wy

packages/fcl-sound/tests/data/wav/reader/valid/euphoric_tape.wav.info.txt

@@ -0,0 +1 @@
+4800 1 8

packages/fcl-sound/tests/tcwavreader.pas

@@ -27,7 +27,12 @@ const
 var
   WavReader: TWavReader;
   InfoFile: TextFile;
-  ExpectedSampleRate, ExpectedChannels, ExpectedBitsPerSample : Integer;
+  RawDataFile: File;
+  ExpectedSampleRate, ExpectedChannels, ExpectedBitsPerSample: Integer;
+  ExpectedData: array of Byte;
+  ActualData: array of Byte;
+  ActualDataLen: Integer;
+  SaveFileMode: Byte;
 begin
   AssignFile(InfoFile, CorrectFileDir + FileName + '.info.txt');
   Reset(InfoFile);
@@ -37,6 +42,21 @@ begin
     CloseFile(InfoFile);
   end;
 
+  SaveFileMode := FileMode;
+  try
+    FileMode := 0;
+    AssignFile(RawDataFile, CorrectFileDir + FileName + '.raw');
+    Reset(RawDataFile, 1);
+    try
+      SetLength(ExpectedData, FileSize(RawDataFile));
+      BlockRead(RawDataFile, ExpectedData[0], Length(ExpectedData));
+    finally
+      CloseFile(RawDataFile);
+    end;
+  finally
+    FileMode := SaveFileMode;
+  end;
+
   WavReader := TWavReader.Create;
   try
     if not WavReader.LoadFromFile(CorrectFileDir + FileName) then
@@ -44,6 +64,10 @@ begin
     AssertEquals('Incorrect sample rate', ExpectedSampleRate, WavReader.fmt.SampleRate);
     AssertEquals('Incorrect number of channels', ExpectedChannels, WavReader.fmt.Channels);
     AssertEquals('Incorrect number of bits per sample', ExpectedBitsPerSample, WavReader.fmt.BitsPerSample);
+    SetLength(ActualData, Length(ExpectedData));
+    ActualDataLen := WavReader.ReadBuf(ActualData[0], Length(ActualData));
+    AssertEquals('Data length', Length(ExpectedData), ActualDataLen);
+    AssertTrue('Data differs', CompareMem(@ExpectedData[0], @ActualData[0], ActualDataLen));
   finally
     FreeAndNil(WavReader);
   end;
@@ -55,7 +79,12 @@ begin
   TestValidFile('44k_mono_16.wav');
   TestValidFile('44k_mono_24.wav');
   TestValidFile('44k_mono_32.wav');
+  TestValidFile('44k_stereo_8.wav');
+  TestValidFile('44k_stereo_16.wav');
+  TestValidFile('44k_stereo_24.wav');
+  TestValidFile('44k_stereo_32.wav');
   TestValidFile('44k_mono_16_tag.wav');
+  TestValidFile('euphoric_tape.wav');
 end;
 
 

packages/fcl-sound/tests/testfclsound.lpi

@@ -49,6 +49,7 @@
     </Target>
     <SearchPaths>
       <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../src"/>
       <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
     <Linking>

packages/graph/src/ptcgraph/ptcgraph.pp

@@ -139,6 +139,8 @@ var
   WindowTitle: AnsiString;
   PTCWrapperObject: TPTCWrapperThread;
 
+function InstallUserMode(Width, Height: SmallInt; Colors: LongInt; HardwarePages: SmallInt; XAspect, YAspect: Word): smallint;
+
 {******************************************************************************}
                                  implementation
 {******************************************************************************}
@@ -156,6 +158,7 @@ var
   VesaInfo: record { dummy, for compatibility with graph.inc under go32v2 }
     ModeList: PInteger;
   end;
+  NextNonStandardModeNumber: LongInt;
 
 {$i graph.inc}
 
@@ -2442,6 +2445,106 @@ end;
     isgraphmode := false;
  end;
 
+  procedure FillCommonVESA16(var mode: TModeInfo);
+  begin
+    mode.HardwarePages := 1;
+    mode.MaxColor := 16;
+    mode.PaletteSize := mode.MaxColor;
+    mode.DirectColor := FALSE;
+    mode.DirectPutPixel  := @ptc_DirectPixelProc_8bpp;
+    mode.PutPixel        := @ptc_PutPixelProc_8bpp;
+    mode.GetPixel        := @ptc_GetPixelProc_8bpp;
+    mode.PutImage        := @ptc_PutImageProc_8bpp;
+    mode.GetImage        := @ptc_GetImageProc_8bpp;
+    mode.GetScanLine     := @ptc_GetScanLineProc_8bpp;
+    mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
+    mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
+    mode.HLine           := @ptc_HLineProc_8bpp;
+    mode.VLine           := @ptc_VLineProc_8bpp;
+    mode.PatternLine     := @ptc_PatternLineProc_8bpp;
+    mode.SetVisualPage   := @ptc_SetVisualPage;
+    mode.SetActivePage   := @ptc_SetActivePage;
+  end;
+
+  procedure FillCommonVESA256(var mode: TModeInfo);
+  begin
+    mode.HardwarePages := 1;
+    mode.MaxColor := 256;
+    mode.PaletteSize := mode.MaxColor;
+    mode.DirectColor := FALSE;
+    mode.DirectPutPixel  := @ptc_DirectPixelProc_8bpp;
+    mode.PutPixel        := @ptc_PutPixelProc_8bpp;
+    mode.GetPixel        := @ptc_GetPixelProc_8bpp;
+    mode.PutImage        := @ptc_PutImageProc_8bpp;
+    mode.GetImage        := @ptc_GetImageProc_8bpp;
+    mode.GetScanLine     := @ptc_GetScanLineProc_8bpp;
+    mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
+    mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
+    //mode.SetAllPalette := {$ifdef fpc}@{$endif}SetVGARGBAllPalette;
+    mode.HLine           := @ptc_HLineProc_8bpp;
+    mode.VLine           := @ptc_VLineProc_8bpp;
+    mode.PatternLine     := @ptc_PatternLineProc_8bpp;
+    mode.SetVisualPage   := @ptc_SetVisualPage;
+    mode.SetActivePage   := @ptc_SetActivePage;
+  end;
+
+  procedure FillCommonVESA32kOr64k(var mode: TModeInfo);
+  begin
+    mode.HardwarePages := 1;
+    mode.DirectColor := TRUE;
+    mode.DirectPutPixel  := @ptc_DirectPixelProc_16bpp;
+    mode.PutPixel        := @ptc_PutPixelProc_16bpp;
+    mode.GetPixel        := @ptc_GetPixelProc_16bpp;
+    mode.PutImage        := @ptc_PutImageProc_16bpp;
+    mode.GetImage        := @ptc_GetImageProc_16bpp;
+    mode.GetScanLine     := @ptc_GetScanLineProc_16bpp;
+    mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
+    mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
+    //mode.SetAllPalette := {$ifdef fpc}@{$endif}SetVGARGBAllPalette;
+    mode.HLine           := @ptc_HLineProc_16bpp;
+    mode.VLine           := @ptc_VLineProc_16bpp;
+    mode.PatternLine     := @ptc_PatternLineProc_16bpp;
+    mode.SetVisualPage   := @ptc_SetVisualPage;
+    mode.SetActivePage   := @ptc_SetActivePage;
+  end;
+
+  procedure FillCommonVESA32k(var mode: TModeInfo);
+  begin
+    FillCommonVESA32kOr64k(mode);
+    mode.MaxColor := 32768;
+    mode.PaletteSize := mode.MaxColor;
+  end;
+  procedure FillCommonVESA64k(var mode: TModeInfo);
+  begin
+    FillCommonVESA32kOr64k(mode);
+    mode.MaxColor := 65536;
+    mode.PaletteSize := mode.MaxColor;
+  end;
+
+{$ifdef FPC_GRAPH_SUPPORTS_TRUECOLOR}
+  procedure FillCommonVESA32bpp(var mode: TModeInfo);
+  begin
+    mode.HardwarePages := 1;
+    mode.MaxColor := 16777216;
+    mode.PaletteSize := mode.MaxColor;
+    mode.DirectColor := TRUE;
+    mode.DirectPutPixel  := @ptc_DirectPixelProc_32bpp;
+    mode.PutPixel        := @ptc_PutPixelProc_32bpp;
+    mode.GetPixel        := @ptc_GetPixelProc_32bpp;
+    mode.PutImage        := @ptc_PutImageProc_32bpp;
+    mode.GetImage        := @ptc_GetImageProc_32bpp;
+    mode.GetScanLine     := @ptc_GetScanLineProc_32bpp;
+    mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
+    mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
+    //mode.SetAllPalette := {$ifdef fpc}@{$endif}SetVGARGBAllPalette;
+    mode.HLine           := @ptc_HLineProc_32bpp;
+    mode.VLine           := @ptc_VLineProc_32bpp;
+    mode.PatternLine     := @ptc_PatternLineProc_32bpp;
+    mode.SetVisualPage   := @ptc_SetVisualPage;
+    mode.SetActivePage   := @ptc_SetActivePage;
+  end;
+{$endif FPC_GRAPH_SUPPORTS_TRUECOLOR}
+
   function QueryAdapterInfo:PModeInfo;
   { This routine returns the head pointer to the list }
   { of supported graphics modes.                      }
@@ -2628,106 +2731,6 @@ end;
       mode.SetActivePage  := @ptc_SetActivePage;
     end;
 
-    procedure FillCommonVESA16(var mode: TModeInfo);
-    begin
-      mode.HardwarePages := 1;
-      mode.MaxColor := 16;
-      mode.PaletteSize := mode.MaxColor;
-      mode.DirectColor := FALSE;
-      mode.DirectPutPixel  := @ptc_DirectPixelProc_8bpp;
-      mode.PutPixel        := @ptc_PutPixelProc_8bpp;
-      mode.GetPixel        := @ptc_GetPixelProc_8bpp;
-      mode.PutImage        := @ptc_PutImageProc_8bpp;
-      mode.GetImage        := @ptc_GetImageProc_8bpp;
-      mode.GetScanLine     := @ptc_GetScanLineProc_8bpp;
-      mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
-      mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
-      mode.HLine           := @ptc_HLineProc_8bpp;
-      mode.VLine           := @ptc_VLineProc_8bpp;
-      mode.PatternLine     := @ptc_PatternLineProc_8bpp;
-      mode.SetVisualPage   := @ptc_SetVisualPage;
-      mode.SetActivePage   := @ptc_SetActivePage;
-    end;
-
-    procedure FillCommonVESA256(var mode: TModeInfo);
-    begin
-      mode.HardwarePages := 1;
-      mode.MaxColor := 256;
-      mode.PaletteSize := mode.MaxColor;
-      mode.DirectColor := FALSE;
-      mode.DirectPutPixel  := @ptc_DirectPixelProc_8bpp;
-      mode.PutPixel        := @ptc_PutPixelProc_8bpp;
-      mode.GetPixel        := @ptc_GetPixelProc_8bpp;
-      mode.PutImage        := @ptc_PutImageProc_8bpp;
-      mode.GetImage        := @ptc_GetImageProc_8bpp;
-      mode.GetScanLine     := @ptc_GetScanLineProc_8bpp;
-      mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
-      mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
-      //mode.SetAllPalette := {$ifdef fpc}@{$endif}SetVGARGBAllPalette;
-      mode.HLine           := @ptc_HLineProc_8bpp;
-      mode.VLine           := @ptc_VLineProc_8bpp;
-      mode.PatternLine     := @ptc_PatternLineProc_8bpp;
-      mode.SetVisualPage   := @ptc_SetVisualPage;
-      mode.SetActivePage   := @ptc_SetActivePage;
-    end;
-
-    procedure FillCommonVESA32kOr64k(var mode: TModeInfo);
-    begin
-      mode.HardwarePages := 1;
-      mode.DirectColor := TRUE;
-      mode.DirectPutPixel  := @ptc_DirectPixelProc_16bpp;
-      mode.PutPixel        := @ptc_PutPixelProc_16bpp;
-      mode.GetPixel        := @ptc_GetPixelProc_16bpp;
-      mode.PutImage        := @ptc_PutImageProc_16bpp;
-      mode.GetImage        := @ptc_GetImageProc_16bpp;
-      mode.GetScanLine     := @ptc_GetScanLineProc_16bpp;
-      mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
-      mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
-      //mode.SetAllPalette := {$ifdef fpc}@{$endif}SetVGARGBAllPalette;
-      mode.HLine           := @ptc_HLineProc_16bpp;
-      mode.VLine           := @ptc_VLineProc_16bpp;
-      mode.PatternLine     := @ptc_PatternLineProc_16bpp;
-      mode.SetVisualPage   := @ptc_SetVisualPage;
-      mode.SetActivePage   := @ptc_SetActivePage;
-    end;
-
-    procedure FillCommonVESA32k(var mode: TModeInfo);
-    begin
-      FillCommonVESA32kOr64k(mode);
-      mode.MaxColor := 32768;
-      mode.PaletteSize := mode.MaxColor;
-    end;
-    procedure FillCommonVESA64k(var mode: TModeInfo);
-    begin
-      FillCommonVESA32kOr64k(mode);
-      mode.MaxColor := 65536;
-      mode.PaletteSize := mode.MaxColor;
-    end;
-
-{$ifdef FPC_GRAPH_SUPPORTS_TRUECOLOR}
-    procedure FillCommonVESA32bpp(var mode: TModeInfo);
-    begin
-      mode.HardwarePages := 1;
-      mode.MaxColor := 16777216;
-      mode.PaletteSize := mode.MaxColor;
-      mode.DirectColor := TRUE;
-      mode.DirectPutPixel  := @ptc_DirectPixelProc_32bpp;
-      mode.PutPixel        := @ptc_PutPixelProc_32bpp;
-      mode.GetPixel        := @ptc_GetPixelProc_32bpp;
-      mode.PutImage        := @ptc_PutImageProc_32bpp;
-      mode.GetImage        := @ptc_GetImageProc_32bpp;
-      mode.GetScanLine     := @ptc_GetScanLineProc_32bpp;
-      mode.SetRGBPalette   := @ptc_SetRGBPaletteProc;
-      mode.GetRGBPalette   := @ptc_GetRGBPaletteProc;
-      //mode.SetAllPalette := {$ifdef fpc}@{$endif}SetVGARGBAllPalette;
-      mode.HLine           := @ptc_HLineProc_32bpp;
-      mode.VLine           := @ptc_VLineProc_32bpp;
-      mode.PatternLine     := @ptc_PatternLineProc_32bpp;
-      mode.SetVisualPage   := @ptc_SetVisualPage;
-      mode.SetActivePage   := @ptc_SetActivePage;
-    end;
-{$endif FPC_GRAPH_SUPPORTS_TRUECOLOR}
-
     procedure FillCommonVESA320x200(var mode: TModeInfo);
     begin
       mode.DriverNumber := VESA;
@@ -2777,7 +2780,6 @@ end;
    var
     graphmode:Tmodeinfo;
     I: Integer;
-    NextNonStandardModeNumber: SmallInt;
    begin
      QueryAdapterInfo := ModeList;
      { If the mode listing already exists... }
@@ -3451,6 +3453,74 @@ end;
          end;
   end;
 
+function InstallUserMode(Width, Height: SmallInt; Colors: LongInt; HardwarePages: SmallInt; XAspect, YAspect: Word): smallint;
+var
+  graphmode: Tmodeinfo;
+begin
+  if (NextNonStandardModeNumber > NonStandardModeNumberMaxLimit) or (HardwarePages < 1) or
+     (Width <= 0) or (Height <= 0) or (XAspect <= 0) or (YAspect <= 0) then
+  begin
+    InstallUserMode := grError;
+    exit;
+  end;
+  InitMode(graphmode);
+  case Colors of
+{    2:
+      begin
+      end;
+    4:
+      begin
+      end;}
+    16:
+      begin
+        FillCommonVESA16(graphmode);
+        graphmode.InitMode := @ptc_InitNonStandard16;
+      end;
+    256:
+      begin
+        FillCommonVESA256(graphmode);
+        graphmode.InitMode := @ptc_InitNonStandard256;
+      end;
+    32768:
+      begin
+        FillCommonVESA32k(graphmode);
+        graphmode.InitMode := @ptc_InitNonStandard32k;
+      end;
+    65536:
+      begin
+        FillCommonVESA64k(graphmode);
+        graphmode.InitMode := @ptc_InitNonStandard64k;
+      end;
+{$ifdef FPC_GRAPH_SUPPORTS_TRUECOLOR}
+    16777216:
+      begin
+        FillCommonVESA32bpp(graphmode);
+        graphmode.InitMode := @ptc_InitNonStandard32bpp;
+      end;
+{$endif FPC_GRAPH_SUPPORTS_TRUECOLOR}
+    else
+      begin
+        InstallUserMode := grError;
+        exit;
+      end;
+  end;
+  with graphmode do
+  begin
+    ModeNumber := NextNonStandardModeNumber;
+    DriverNumber := VESA;
+    WriteStr(ModeName, Width, ' x ', Height, ' VESA');
+    MaxX := Width - 1;
+    MaxY := Height - 1;
+    HardwarePages := 1;
+  end;
+  graphmode.XAspect := XAspect;
+  graphmode.YAspect := YAspect;
+  graphmode.HardwarePages := HardwarePages - 1;
+  AddMode(graphmode);
+  Inc(NextNonStandardModeNumber);
+  InstallUserMode := graphmode.ModeNumber;
+end;
+
 initialization
   WindowTitle := ParamStr(0);
   PTCFormat8 := TPTCFormatFactory.CreateNew(8);

packages/pastojs/src/fppas2js.pp

@@ -1538,6 +1538,7 @@ type
     procedure AddElevatedLocal(El: TPasElement); virtual;
     procedure ClearElementData; virtual;
     function GenerateGUID(El: TPasClassType): string; virtual;
+    function CheckCallAsyncFuncResult(Param: TPasExpr; out ResolvedEl: TPasResolverResult): boolean; virtual;
   protected
     // generic/specialize
     procedure SpecializeGenericIntf(SpecializedItem: TPRSpecializedItem);
@@ -5177,6 +5178,35 @@ begin
   Result:=Result+'}';
 end;
 
+function TPas2JSResolver.CheckCallAsyncFuncResult(Param: TPasExpr; out
+  ResolvedEl: TPasResolverResult): boolean;
+var
+  PathEnd: TPasExpr;
+  Ref: TResolvedReference;
+  Decl: TPasElement;
+  DeclFunc: TPasFunction;
+begin
+  Result:=false;
+  PathEnd:=GetPathEndIdent(Param,true);
+  if (PathEnd<>nil) and (PathEnd.CustomData is TResolvedReference) then
+    begin
+    Ref:=TResolvedReference(PathEnd.CustomData);
+    Decl:=Ref.Declaration;
+    if Decl is TPasFunction then
+      begin
+      DeclFunc:=TPasFunction(Decl);
+      if DeclFunc.IsAsync then
+        begin
+        // await(CallAsyncFunction)  ->  use Pascal result type (not TJSPromise)
+        // Note the missing rcCall flag
+        ComputeResultElement(DeclFunc.FuncType.ResultEl,ResolvedEl,[],PathEnd);
+        exit(true);
+        end;
+      end;
+    end;
+  ResolvedEl:=Default(TPasResolverResult);
+end;
+
 procedure TPas2JSResolver.SpecializeGenericIntf(
   SpecializedItem: TPRSpecializedItem);
 begin
@@ -5889,7 +5919,7 @@ const
 var
   Params: TParamsExpr;
   Param: TPasExpr;
-  ParamResolved: TPasResolverResult;
+  ParamResolved, Param2Resolved: TPasResolverResult;
   ParentProc: TPasProcedure;
   TypeEl: TPasType;
 begin
@@ -5934,7 +5964,16 @@ begin
         and (TypeEl.CustomData is TResElDataBaseType) then
       // base type
     else if (TypeEl<>nil) and (ParamResolved.IdentEl is TPasType) then
+      begin
       // custom type
+      if (ParamResolved.BaseType=btContext)
+          and (ParamResolved.LoTypeEl is TPasClassType)
+          and IsExternalClass_Name(TPasClassType(ParamResolved.LoTypeEl),'Promise') then
+        begin
+        // awit(TJSPromise,x) ->  await resolves all promises
+        exit(CheckRaiseTypeArgNo(20201120001741,1,Param,ParamResolved,'non Promise type',RaiseOnError));
+        end;
+      end
     else
       exit(CheckRaiseTypeArgNo(20200519151816,1,Param,ParamResolved,'jsvalue',RaiseOnError));
 
@@ -5949,16 +5988,40 @@ begin
 
     // check second param TJSPromise
     Param:=Params.Params[1];
-    ComputeElement(Param,ParamResolved,[]);
-    if not (rrfReadable in ParamResolved.Flags) then
-      exit(CheckRaiseTypeArgNo(20200520091707,2,Param,ParamResolved,
-         'instance of TJSPromise',RaiseOnError));
+    if CheckCallAsyncFuncResult(Param,Param2Resolved) then
+      begin
+      // await(T,CallAsyncFuncResultS)
+      if (Param2Resolved.BaseType=btContext)
+          and (Param2Resolved.LoTypeEl is TPasClassType)
+          and IsExternalClass_Name(TPasClassType(Param2Resolved.LoTypeEl),'Promise') then
+        begin
+        // await(T,CallAsyncFuncReturningPromise) -> good
+        end
+      else
+        begin
+        // await(T,CallAsyncFuncResultS)
+        // Note: Actually this case is not needed, as you can simply write await(AsyncCall)
+        //       but it helps some parsers and some people find it more readable
+        // make sure you cannot shoot yourself in the foot: -> check T=S OR S is T
+        ParamResolved.Flags:=[rrfReadable,rrfWritable];
+        ParamResolved.IdentEl:=nil;
+        Result:=CheckParamResCompatibility(Param,Param2Resolved,ParamResolved,1,RaiseOnError,false);
+        exit;
+        end;
+      end
+    else
+      begin
+      ComputeElement(Param,Param2Resolved,[]);
+      if not (rrfReadable in Param2Resolved.Flags) then
+        exit(CheckRaiseTypeArgNo(20200520091707,2,Param,Param2Resolved,
+           'instance of TJSPromise',RaiseOnError));
 
-    if (ParamResolved.BaseType<>btContext)
-        or not (ParamResolved.LoTypeEl is TPasClassType)
-        or not IsExternalClass_Name(TPasClassType(ParamResolved.LoTypeEl),'Promise') then
-      exit(CheckRaiseTypeArgNo(20200520091707,2,Param,ParamResolved,
-         'TJSPromise',RaiseOnError));
+      if (Param2Resolved.BaseType<>btContext)
+          or not (Param2Resolved.LoTypeEl is TPasClassType)
+          or not IsExternalClass_Name(TPasClassType(Param2Resolved.LoTypeEl),'Promise') then
+        exit(CheckRaiseTypeArgNo(20200520091707,2,Param,Param2Resolved,
+           'TJSPromise',RaiseOnError));
+      end;
 
     Result:=CheckBuiltInMaxParamCount(Proc,Params,2,RaiseOnError,Signature2);
     end;
@@ -5970,32 +6033,15 @@ procedure TPas2JSResolver.BI_AWait_OnGetCallResult(Proc: TResElDataBuiltInProc;
 // function await(T; p: TJSPromise): T
 // await(Proc());
 var
-  Param, PathEnd: TPasExpr;
-  Ref: TResolvedReference;
-  Decl: TPasElement;
-  DeclFunc: TPasFunction;
+  Param: TPasExpr;
 begin
   Param:=Params.Params[0];
   if length(Params.Params)=1 then
     begin
     // await(expr)
-    PathEnd:=GetPathEndIdent(Param,true);
-    if (PathEnd<>nil) and (PathEnd.CustomData is TResolvedReference) then
-      begin
-      Ref:=TResolvedReference(PathEnd.CustomData);
-      Decl:=Ref.Declaration;
-      if Decl is TPasFunction then
-        begin
-        DeclFunc:=TPasFunction(Decl);
-        if DeclFunc.IsAsync then
-          begin
-          // await(CallAsyncFunction)  ->  use Pascal result type (not TJSPromise)
-          // Note the missing rcCall flag
-          ComputeResultElement(DeclFunc.FuncType.ResultEl,ResolvedEl,[],PathEnd);
-          exit;
-          end;
-        end;
-      end;
+    if CheckCallAsyncFuncResult(Param,ResolvedEl) then
+      // await(CallAsynFuncResultT): T
+      exit;
     // await(expr:T):T
     end
   else

packages/pastojs/tests/tcmodules.pas

@@ -877,6 +877,7 @@ type
     Procedure TestAsync_ConstructorFail;
     Procedure TestAsync_PropertyGetterFail;
     Procedure TestAwait_NonPromiseWithTypeFail;
+    Procedure TestAwait_AsyncCallTypeMismatch;
     Procedure TestAWait_OutsideAsyncFail;
     Procedure TestAWait_Result;
     Procedure TestAWait_ExternalClassPromise;
@@ -32399,6 +32400,28 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestAwait_AsyncCallTypeMismatch;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '  end;',
+  '  TBird = class',
+  '  end;',
+  'function Fly: TObject; async;',
+  'begin',
+  'end;',
+  'procedure Run; async;',
+  'begin',
+  '  await(TBird,Fly);',
+  'end;',
+  'begin',
+  '']);
+  SetExpectedPasResolverError('Incompatible type arg no. 2: Got "TObject", expected "TBird"',nIncompatibleTypeArgNo);
+  ConvertProgram;
+end;
+
 procedure TTestModule.TestAWait_OutsideAsyncFail;
 begin
   StartProgram(false);
@@ -32468,12 +32491,15 @@ begin
   'type',
   '  TJSPromise = class external name ''Promise''',
   '  end;',
-  'function Fly(w: word): TJSPromise; async;',
+  'function Fly(w: word): TJSPromise;',
   'begin',
   'end;',
   'function Jump(w: word): word; async;',
   'begin',
   'end;',
+  'function Eat(w: word): TJSPromise; async;',
+  'begin',
+  'end;',
   'function Run(d: double): word; async;',
   'var',
   '  p: TJSPromise;',
@@ -32481,13 +32507,15 @@ begin
   '  Result:=await(word,p);', // promise needs type
   '  Result:=await(word,Fly(3));', // promise needs type
   '  Result:=await(Jump(4));', // async non promise must omit the type
+  '  Result:=await(word,Jump(5));', // async call can provide fitting type
+  '  Result:=await(word,Eat(6));', // promise needs type
   'end;',
   'begin',
   '']);
   ConvertProgram;
   CheckSource('TestAWait_ExternalClassPromise',
     LinesToStr([ // statements
-    'this.Fly = async function (w) {',
+    'this.Fly = function (w) {',
     '  var Result = null;',
     '  return Result;',
     '};',
@@ -32495,12 +32523,18 @@ begin
     '  var Result = 0;',
     '  return Result;',
     '};',
+    'this.Eat = async function (w) {',
+    '  var Result = null;',
+    '  return Result;',
+    '};',
     'this.Run = async function (d) {',
     '  var Result = 0;',
     '  var p = null;',
     '  Result = await p;',
     '  Result = await $mod.Fly(3);',
     '  Result = await $mod.Jump(4);',
+    '  Result = await $mod.Jump(5);',
+    '  Result = await $mod.Eat(6);',
     '  return Result;',
     '};',
     '']),

packages/qlunits/examples/qlcube.pas

@@ -0,0 +1,209 @@
+{
+    Copyright (c) 2017-2020 Karoly Balogh
+
+    Rotating 3D cube on a Sinclair QL
+    Example program for Free Pascal's Sinclair QL support
+
+    This example program is in the Public Domain under the terms of
+    Unlicense: http://unlicense.org/
+
+ **********************************************************************}
+
+program qlcube;
+
+uses
+  qdos, qlfloat;
+
+type
+  tvertex = record
+    x: longint;
+    y: longint;
+    z: longint;
+  end;
+
+const
+  cube: array[0..7] of tvertex = (
+     ( x: -1; y: -1; z: -1; ), // 0
+     ( x:  1; y: -1; z: -1; ), // 1
+     ( x:  1; y:  1; z: -1; ), // 2
+     ( x: -1; y:  1; z: -1; ), // 3
+
+     ( x: -1; y: -1; z:  1; ), // 4
+     ( x:  1; y: -1; z:  1; ), // 5
+     ( x:  1; y:  1; z:  1; ), // 6
+     ( x: -1; y:  1; z:  1; )  // 7
+  );
+
+type
+  tface = record
+    v1, v2, v3: longint;
+    edge: longint;
+  end;
+
+const
+  sincos_table: array[0..255] of longint = (
+         0,  1608,  3216,  4821,  6424,  8022,  9616, 11204,
+     12785, 14359, 15924, 17479, 19024, 20557, 22078, 23586,
+     25079, 26557, 28020, 29465, 30893, 32302, 33692, 35061,
+     36409, 37736, 39039, 40319, 41575, 42806, 44011, 45189,
+     46340, 47464, 48558, 49624, 50659, 51664, 52638, 53580,
+     54490, 55367, 56211, 57021, 57797, 58537, 59243, 59913,
+     60546, 61144, 61704, 62227, 62713, 63161, 63571, 63943,
+     64276, 64570, 64826, 65042, 65219, 65357, 65456, 65515,
+     65535, 65515, 65456, 65357, 65219, 65042, 64826, 64570,
+     64276, 63943, 63571, 63161, 62713, 62227, 61704, 61144,
+     60546, 59913, 59243, 58537, 57797, 57021, 56211, 55367,
+     54490, 53580, 52638, 51664, 50659, 49624, 48558, 47464,
+     46340, 45189, 44011, 42806, 41575, 40319, 39039, 37736,
+     36409, 35061, 33692, 32302, 30893, 29465, 28020, 26557,
+     25079, 23586, 22078, 20557, 19024, 17479, 15924, 14359,
+     12785, 11204,  9616,  8022,  6424,  4821,  3216,  1608,
+         0, -1608, -3216, -4821, -6424, -8022, -9616,-11204,
+    -12785,-14359,-15924,-17479,-19024,-20557,-22078,-23586,
+    -25079,-26557,-28020,-29465,-30893,-32302,-33692,-35061,
+    -36409,-37736,-39039,-40319,-41575,-42806,-44011,-45189,
+    -46340,-47464,-48558,-49624,-50659,-51664,-52638,-53580,
+    -54490,-55367,-56211,-57021,-57797,-58537,-59243,-59913,
+    -60546,-61144,-61704,-62227,-62713,-63161,-63571,-63943,
+    -64276,-64570,-64826,-65042,-65219,-65357,-65456,-65515,
+    -65535,-65515,-65456,-65357,-65219,-65042,-64826,-64570,
+    -64276,-63943,-63571,-63161,-62713,-62227,-61704,-61144,
+    -60546,-59913,-59243,-58537,-57797,-57021,-56211,-55367,
+    -54490,-53580,-52638,-51664,-50659,-49624,-48558,-47464,
+    -46340,-45189,-44011,-42806,-41575,-40319,-39039,-37736,
+    -36409,-35061,-33692,-32302,-30893,-29465,-28020,-26557,
+    -25079,-23586,-22078,-20557,-19024,-17479,-15924,-14359,
+    -12785,-11204, -9616, -8022, -6424, -4821, -3216, -1608
+  );
+
+function sin(x: longint): longint; inline;
+begin
+  sin:=sincos_table[x and 255];
+end;
+
+function cos(x: longint): longint; inline;
+begin
+  cos:=sincos_table[(x + 64) and 255];
+end;
+
+function mulfp(a, b: longint): longint; inline;
+begin
+  mulfp:=sarint64((int64(a) * b),16);
+end;
+
+function divfp(a, b: longint): longint;
+begin
+  divfp:=(int64(a) shl 16) div b;
+end;
+
+procedure rotate_vertex(const v: tvertex; var vr: tvertex; xa, ya, za: longint);
+var
+  x,y,z: longint;
+  s,c: longint;
+begin
+  s   :=sin(ya);
+  c   :=cos(ya);
+  x   :=mulfp(c,v.x) - mulfp(s,v.z);
+  z   :=mulfp(s,v.x) + mulfp(c,v.z);
+  if za <> 0 then
+    begin
+      vr.x:=mulfp(cos(za),x)   + mulfp(sin(za),v.y);
+      y   :=mulfp(cos(za),v.y) - mulfp(sin(za),x);
+    end
+  else
+    begin
+      vr.x:=x;
+      y:=v.y;
+    end;
+  vr.z:=mulfp(cos(xa),z)   - mulfp(sin(xa),y);
+  vr.y:=mulfp(sin(xa),z)   + mulfp(cos(xa),y);
+end;
+
+procedure perspective_vertex(const v: tvertex; zc: longint; var xr,yr: longint);
+var
+  rzc: longint;
+begin
+  rzc:=divfp(1 shl 16,(v.z - zc));
+  xr:=mulfp(mulfp(v.x,zc),rzc);
+  yr:=mulfp(mulfp(v.y,zc),rzc);
+end;
+
+procedure init_cube;
+var
+  i: longint;
+begin
+  for i:=low(cube) to high(cube) do
+    begin
+      cube[i].x:=cube[i].x shl 16;
+      cube[i].y:=cube[i].y shl 16;
+      cube[i].z:=cube[i].z shl 16;
+    end;
+end;
+
+
+var
+  mx, my: smallint;
+
+function min(a, b: smallint): smallint;
+begin
+  if a < b then
+    min:=a
+  else
+    min:=b;
+end;
+
+procedure draw_line(x1,y1,x2,y2: smallint);
+begin
+  sd_line(QCON,-1,x1,y1,x2,y2);
+end;
+
+procedure cube_redraw;
+var
+  i,s,e,cx,cy,vx,vy: longint;
+  vr: tvertex;
+  scale: longint;
+  rect:TQLRect;
+  fcubex: array[low(cube)..high(cube)] of Tqlfloat;
+  fcubey: array[low(cube)..high(cube)] of Tqlfloat;
+begin
+  rect.q_x:=0;
+  rect.q_y:=0;
+  rect.q_width:=140;
+  rect.q_height:=100;
+
+  scale:=(min(rect.q_width,rect.q_height) div 6) shl 16;
+  cx:=rect.q_x + rect.q_width div 2;
+  cy:=rect.q_y + rect.q_height div 2;
+  for i:=low(cube) to high(cube) do
+    begin
+      rotate_vertex(cube[i],vr,-my,-mx,0);
+      perspective_vertex(vr,3 shl 16,vx,vy);
+      longint_to_qlfp(@fcubex[i],cx + sarlongint(mulfp(vx,scale),16));
+      longint_to_qlfp(@fcubey[i],cy + sarlongint(mulfp(vy,scale),16));
+    end;
+
+  sd_clear(QCON,-1);
+  for i:=0 to 3 do 
+    begin
+      e:=(i+1) and 3;
+      sd_line(QCON,-1,@fcubex[i],@fcubey[i],@fcubex[e],@fcubey[e]);
+      s:=i+4; e:=e+4;
+      sd_line(QCON,-1,@fcubex[s],@fcubey[s],@fcubex[e],@fcubey[e]);
+      sd_line(QCON,-1,@fcubex[i],@fcubey[i],@fcubex[s],@fcubey[s]);
+    end;
+end;
+
+procedure main_loop;
+begin
+  repeat
+    inc(mx,5);
+    inc(my,7);
+    cube_redraw;
+  until false;
+end;
+
+begin
+  init_cube;
+
+  main_loop;
+end.

packages/qlunits/fpmake.pp

@@ -29,9 +29,10 @@ begin
     P.OSes:=[sinclairql];
 
     T:=P.Targets.AddUnit('qdos.pas');
+    T:=P.Targets.AddUnit('qlfloat.pas');
 
-//    P.ExamplePath.Add('examples');
-//    T:=P.Targets.AddExampleProgram('.pas');
+    P.ExamplePath.Add('examples');
+    T:=P.Targets.AddExampleProgram('qlcube.pas');
 
 {$ifndef ALLPACKAGES}
     Run;

packages/qlunits/src/qdos.pas

@@ -44,20 +44,155 @@ const
   ERR_EX = -17;  { Expression error. }
   ERR_OV = -18;  { Arithmetic overflow. }
   ERR_NI = -19;  { Not implemented. }
-  ERR_RO = -20;	 { Read only. }
+  ERR_RO = -20;  { Read only. }
   ERR_BL = -21;  { Bad line of Basic. }
 
+const
+  Q_OPEN = 0;
+  Q_OPEN_IN = 1;
+  Q_OPEN_NEW = 2;
+  Q_OPEN_OVER = 3;  { Not available on microdrives. }
+  Q_OPEN_DIR = 4;
+
+type
+  Tqlfloat = array[0..5] of byte;
+  Pqlfloat = ^Tqlfloat;
+
+type
+  TQLRect = record
+    q_width : word;
+    q_height : word;
+    q_x : word;
+    q_y : word;
+  end;
+  PQLRect = ^TQLRect;
+
+type
+  TWindowDef = record
+    border_colour : byte;
+    border_width : byte;
+    paper : byte;
+    ink : byte;
+    width : word;
+    height : word;
+    x_origin: word;
+    y_origin: word;
+  end;
+  PWindowDef = ^TWindowDef;
+
 
 { the functions declared as external here are implemented in the system unit. They're included
   here via externals, do avoid double implementation of assembler wrappers (KB) }
 
+function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; external name '_mt_inf';
+
+procedure mt_dmode(s_mode: pword; d_type: pword); external name '_mt_dmode';
+
 function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
 procedure mt_rechp(area: pointer); external name '_mt_rechp';
 
+function io_open_qlstr(name_qlstr: pointer; mode: longint): Tchanid; external name '_io_open_qlstr';
+function io_open(name: pchar; mode: longint): Tchanid; external name '_io_open';
+function io_close(chan: Tchanid): longint; external name '_io_close';
+
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
 function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
 
+function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; external name '_sd_wdef'; 
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; external name '_sd_clear';
+
+function ut_con(params: PWindowDef): Tchanid; external name '_ut_con';
+function ut_scr(params: PWindowDef): Tchanid; external name '_ut_scr';
+
+
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: Pqlfloat; y: Pqlfloat);
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: double; y: double);
+
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: Pqlfloat; y_start: Pqlfloat; x_end: Pqlfloat; y_end: Pqlfloat);
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: double; y_start: double; x_end: double; y_end: double);
+
 
 implementation
 
+uses
+  qlfloat;
+
+const
+  _SD_POINT = $30;
+  _SD_LINE = $31;
+
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: Pqlfloat; y: Pqlfloat);
+var
+  stack: array[0..1] of TQLFloat;
+begin
+  stack[1]:=x^;
+  stack[0]:=y^;
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_POINT,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+procedure sd_point(chan: Tchanid; timeout: Ttimeout; x: double; y: double);
+var
+  stack: array[0..1] of TQLFloat;
+begin
+  double_to_qlfp(@stack[1],@x);
+  double_to_qlfp(@stack[0],@y);
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_POINT,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: Pqlfloat; y_start: Pqlfloat; x_end: Pqlfloat; y_end: Pqlfloat);
+var
+  stack: array[0..3] of TQLFloat;
+begin
+  stack[3]:=x_start^;
+  stack[2]:=y_start^;
+  stack[1]:=x_end^;
+  stack[0]:=y_end^;
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_LINE,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+procedure sd_line(chan: Tchanid; timeout: Ttimeout; x_start: double; y_start: double; x_end: double; y_end: double);
+var
+  stack: array[0..3] of TQLFloat;
+begin
+  double_to_qlfp(@stack[3],@x_start);
+  double_to_qlfp(@stack[2],@y_start);
+  double_to_qlfp(@stack[1],@x_end);
+  double_to_qlfp(@stack[0],@y_end);
+  asm
+    move.l d3,-(sp)
+    move.w timeout,d3
+    move.l chan,a0
+    lea.l stack,a1
+    moveq.l #_SD_LINE,d0
+    trap #3
+    move.l (sp)+,d3
+  end;
+end;
+
+
 end.

packages/qlunits/src/qlfloat.pas

@@ -0,0 +1,182 @@
+{
+    Conversion code from various number formats to QL Float format.
+
+    Code ported from the C68/QL-GCC libc implementation available at:
+    http://morloch.hd.free.fr/qdos/qdosgcc.html
+
+    The QL wiki claims the original of these sources are by
+    Dave Walker, and they are in the Public Domain.
+    https://qlwiki.qlforum.co.uk/doku.php?id=qlwiki:c68
+
+ **********************************************************************}
+unit qlfloat;
+
+interface
+
+uses
+  qdos;
+
+function longint_to_qlfp(qlf: Pqlfloat; val: longint): Pqlfloat;
+function double_to_qlfp(qlf: Pqlfloat; val: Pdouble): Pqlfloat;
+
+
+implementation
+
+function longint_to_qlfp(qlf: Pqlfloat; val: longint): Pqlfloat; assembler; nostackframe;
+asm
+  { pointer to qlfloat is in a0 }
+  { val is in d0 }
+
+  movem.l d2-d4/a0,-(sp)  { save register variables and a0 }
+  moveq.l #0,d2           { sign value }
+  move.l  d2,d3           { shift value }
+  tst.l   d0              { zero or -ve ? }
+  beq     @zeroval        { zero }
+  bpl     @plusval        { +ve }
+
+{ i is negative here. set the sign value then make i positive }
+
+  moveq   #1,d2           { boolean to say -ve }
+  not.l   d0              { i has all bits reversed }
+  bne     @plusval        { i was not -1, so can continue }
+
+{ i was -1, so cannot go into following loop, as it now is zero }
+
+  moveq   #0,d2           { pretend i was positive }
+  move.l  #$80000000,d1   { set d1 correctly }
+  move.w  #31,d3          { shift value }
+  bra     @outloop        { continue }
+
+@plusval:
+  move.l  d0,d1           { save a copy of the original i }
+
+{ check for shortcuts with shifts }
+
+  and.l   #$ffffff00,d0   { shift by 23 ? }
+  bne     @bigger23       { no cheat available }
+  move.w  #23,d3          { shift value is 23 }
+  lsl.l   d3,d1           { shift copy of i }
+  bra     @nbigger        { continue }
+
+{ check for 15 bit shortcut shift }
+
+@bigger23:
+  move.l  d1,d0           { restore i }
+  and.l   #$ffff0000,d0   { shift by 15 ? }
+  bne     @nbigger        { no cheat available }
+  move.w  #15,d3          { shift value is 15 }
+  lsl.l   d3,d1           { shift copy of i }
+
+{ no shortcuts available }
+
+@nbigger:
+  move.l  d1,d0           { restore i }
+  and.l   #$40000000,d0   { if(!(i & 0x40000000)) }
+  bne     @outloop        { bit is set, no more shifts }
+  lsl.l   #1,d1           { shift copy of i }
+  addq.l  #1,d3           { increment shift count }
+  bra     @nbigger        { ensures i is restored }
+
+{ finished shifts - copy into qlfloat }
+{ correct shifted i is in d1, d0 contains i & 0x40000000 }
+
+@outloop:
+  move.w  #$81f,d4
+  sub.w   d3,d4           { set exponent correctly }
+  move.w  d4,(a0)+        { copy into exponent }
+
+{ difference here between positive and negative numbers
+; negative should just be shifted until first zero, so as we
+; have 2s complemented and shifted until first one, we must now
+; re-complement what is left }
+
+  tst.b   d2
+  beq     @setmant        { positive value here - just copy it }
+
+{ negative value, xor it with -1 shifted by same amount as in shift (d3)
+; to convert it back to -ve representation }
+
+  moveq.l #-1,d2          { set d2 to all $FFs }
+  lsl.l   d3,d2           { shift it by shift (d3 ) }
+  eor.l   d2,d1           { not the value by xoring }
+
+{ negative value restored by above }
+
+@setmant:
+  move.l  d1,(a0)         { copy into mantissa }
+@fin:
+  movem.l (sp)+,d2-d4/a0  { reset register variables and return value }
+  rts
+
+{ quick exit if zero }
+
+@zeroval:
+  move.w  d2,(a0)+        { zero exponent }
+  move.l  d2,(a0)         { zero mantissa }
+  bra     @fin
+end;
+
+
+function double_to_qlfp(qlf: Pqlfloat; val: Pdouble): Pqlfloat; assembler; nostackframe;
+asm
+{----------------------------- IEEE -----------------------------------
+; routine to convert IEEE double precision (8 byte) floating point
+; to a QLFLOAT_t.
+}
+  { pointer to qlfloat is in a0 }
+  move.l  (a1),d0        { high long of IEEE double }
+
+{ SNG - avoid loading low part for now so we can treat D1 as temporary }
+
+  add.l   d0,d0          { Put sign bit in carry }
+  lsr.l   #1,d0          { put zero where sign was }
+  bne     @notzero       { not zero }
+  move.l  4(a1),d1       { Test low bits too (probably zero!) }
+  bne     @notzero
+
+{ here the double was a signed zero - set the QLFLOAT_t and return }
+
+  move.w  d1,(a0)+       { We know that D1 is 0 at this point }
+  bra     @positive
+
+{ was not zero - do manipulations }
+
+@notzero:
+  move.l  d0,d1          { set non-signed high part copy }
+{                          We are going to lose least significant byte so we
+;                          can afford to over-write it.  We can thus take
+;                          advantage that the shift size when specified in
+;                          a register is modulo 64 }
+  move.b  #20,d0         { shift amount for exponent }
+  lsr.l   d0,d0          { get exponent - tricky but it works! }
+  add.w   #$402,d0       { adjust to QLFLOAT_t exponent }
+  move.w  d0,(a0)+       { set QLFLOAT_t exponent }
+
+{ now deal with mantissa }
+
+  and.l   #$fffff,d1     { get top 20 mantissa bits }
+  or.l    #$100000,d1    { add implied bit }
+  moveq   #10,d0         { shift amount ;; save another 2 code bytes }
+  lsl.l   d0,d1          { shift top 21 bits into place }
+
+  move.l  4(a1),d0       { get less significant bits }
+
+{                          We are going to lose least significant byte so we
+;                          can afford to over-write it.  We can thus take
+;                          advantage that the shift size when specified in
+;                          a register is modulo 64 }
+  move.b  #22,d0         { amount to shift down low long: not MOVEQ! }
+  lsr.l   d0,d0          { position low 10 bits of mantissa }
+  or.l    d0,d1          { D1 now positive mantissa }
+
+@lowzer:
+  tst.b   (a1)           { Top byte of IEEE argument }
+  bpl     @positive      { No need to negate if positive }
+  neg.l   d1             { Mantissa in D1 now }
+@positive:
+  move.l  d1,(a0)        { put mantissa in QLFLOAT_t }
+  subq.l  #2,a0          { correct for return address }
+  move.l  a0,d0          { set return value as original QLFLOAT_t address }
+end;
+
+end.

packages/tosunits/Makefile

@@ -347,7 +347,7 @@ FPMAKE_SKIP_CONFIG=-n
 FPCFPMAKE=$(FPC)
 endif
 endif
-override PACKAGE_NAME=ami-extra
+override PACKAGE_NAME=tosunits
 override PACKAGE_VERSION=3.3.1
 FPMAKE_BIN_CLEAN=$(wildcard ./fpmake$(SRCEXEEXT))
 ifdef OS_TARGET

packages/tosunits/Makefile.fpc

@@ -3,7 +3,7 @@
 #
 
 [package]
-name=ami-extra
+name=tosunits
 version=3.3.1
 
 [require]

rtl/sinclairql/qdos.inc

@@ -17,6 +17,7 @@
 
 const
   _MT_INF   = $00;
+  _MT_DMODE = $10;
   _MT_ALCHP = $18;
   _MT_RECHP = $19;
 
@@ -35,6 +36,18 @@ asm
   move.l  d1,d0     { jobid }
 end;
 
+procedure mt_dmode(s_mode: pword; d_type: pword); assembler; nostackframe; public name '_mt_dmode';
+asm
+  movem.l d2/a3-a4,-(sp)
+  move.w (a0),d1
+  move.w (a1),d2
+  moveq.l #_MT_DMODE,d0
+  trap #1
+  move.w d1,(a0)
+  move.w d2,(a1) 
+  movem.l (sp)+,d2/a3-a4
+end;
+
 function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; assembler; nostackframe; public name '_mt_alchp';
 asm
   movem.l d2-d3/a2-a3,-(sp)
@@ -109,6 +122,8 @@ end;
 const
   _IO_SBYTE = $05;
   _IO_SSTRG = $07;
+  _SD_WDEF = $0D;
+  _SD_CLEAR = $20;
 
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; assembler; public name '_io_sbyte';
 asm
@@ -147,12 +162,35 @@ asm
   movem.l (sp)+,d2-d3
 end;
 
+function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; assembler; public name '_sd_wdef'; 
+asm
+  movem.l d2-d3,-(sp)
+  move.l window,a1
+  move.w timeout,d3
+  move.w border_width,d2
+  move.b border_colour,d1
+  move.l chan,a0
+  moveq.l #_SD_WDEF,d0
+  trap #3 
+  movem.l (sp)+,d2-d3
+end;
+
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; assembler; public name '_sd_clear';
+asm
+  move.l d3,-(sp)
+  move.w timeout,d3
+  move.l chan,a0
+  moveq.l #_SD_CLEAR,d0
+  trap #3 
+  move.l (sp)+,d3
+end;
+
 
 const
   _UT_CON = $c6;
   _UT_SCR = $c8;
 
-function ut_con(params: PConScrParams): Tchanid; assembler; nostackframe; public name '_ut_con';
+function ut_con(params: PWindowDef): Tchanid; assembler; nostackframe; public name '_ut_con';
 asm
   movem.l d2-d3/a2-a3,-(sp)
   move.l params,a1
@@ -164,7 +202,7 @@ asm
   movem.l (sp)+,d2-d3/a2-a3
 end;
 
-function ut_scr(params: PConScrParams): Tchanid; assembler; nostackframe; public name '_ut_scr';
+function ut_scr(params: PWindowDef): Tchanid; assembler; nostackframe; public name '_ut_scr';
 asm
   movem.l d2-d3/a2-a3,-(sp)
   move.l params,a1

rtl/sinclairql/qdosfuncs.inc

@@ -17,6 +17,8 @@
 
 function mt_inf(sys_vars: ppchar; ver_ascii: plongint): Tjobid; external name '_mt_inf';
 
+procedure mt_dmode(s_mode: pword; d_type: pword); external name '_mt_dmode';
+
 function mt_alchp(size: dword; sizegot: pdword; jobid: Tjobid): pointer; external name '_mt_alchp';
 procedure mt_rechp(area: pointer); external name '_mt_rechp';
 
@@ -27,5 +29,8 @@ function io_close(chan: Tchanid): longint; external name '_io_close';
 function io_sbyte(chan: Tchanid; timeout: Ttimeout; c: char): longint; external name '_io_sbyte';
 function io_sstrg(chan: Tchanid; timeout: Ttimeout; buf: pointer; len: smallint): smallint; external name '_io_sstrg';
 
-function ut_con(params: PConScrParams): Tchanid; external name '_ut_con';
-function ut_scr(params: PConScrParams): Tchanid; external name '_ut_scr';
+function sd_wdef(chan: Tchanid; timeout: Ttimeout; border_colour: byte; border_width: word; window: PQLRect): longint; external name '_sd_wdef'; 
+function sd_clear(chan: Tchanid; timeout: Ttimeout): longint; external name '_sd_clear';
+
+function ut_con(params: PWindowDef): Tchanid; external name '_ut_con';
+function ut_scr(params: PWindowDef): Tchanid; external name '_ut_scr';

rtl/sinclairql/qdosh.inc

@@ -49,14 +49,29 @@ const
   Q_OPEN_OVER = 3;  { Not available on microdrives. }
   Q_OPEN_DIR = 4;
 
+type
+  Tqlfloat = array[0..5] of byte;
+  Pqlfloat = ^Tqlfloat;
 
 type
-  TConScrParams = record
-    bordercolor:  byte;
-    bordersize:   byte;
-    papercolor:   byte;
-    inkcolor:     byte;
-    width,height: word;
-    x,y:          word;
+  TQLRect = record
+    q_width : word;
+    q_height : word;
+    q_x : word;
+    q_y : word;
   end;
-  PConScrParams = ^TConScrParams;
+  PQLRect = ^TQLRect;
+
+type
+  TWindowDef = record
+    border_colour : byte;
+    border_width : byte;
+    paper : byte;
+    ink : byte;
+    width : word;
+    height : word;
+    x_origin: word;
+    y_origin: word;
+  end;
+  PWindowDef = ^TWindowDef;
+

rtl/sinclairql/sysfile.inc

@@ -22,6 +22,7 @@
 { close a file from the handle value }
 procedure do_close(handle : longint);
 begin
+  Error2InOutRes(io_close(handle));
 end;
 
 
@@ -36,8 +37,15 @@ end;
 
 
 function do_write(h: longint; addr: pointer; len: longint) : longint;
+var
+  res: longint;
 begin
-  do_write:=-1;
+  do_write:=0;
+  res:=io_sstrg(h, -1, addr, len);
+  if res < 0 then
+    Error2InOutRes(res)
+  else
+    do_write:=res;
 end;
 
 
@@ -84,7 +92,73 @@ procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
   when (flags and $1000)  the file will be truncate/rewritten
   when (flags and $10000) there is no check for close (needed for textfiles)
 }
+var
+  res: longint;
+  openMode: longint;
 begin
+  openMode:=Q_OPEN;
+
+  { close first if opened }
+  if ((flags and $10000)=0) then
+   begin
+     case filerec(f).mode of
+       fmInput, fmOutput, fmInout:
+         do_close(filerec(f).handle);
+       fmClosed: ;
+     else
+       begin
+         InOutRes:=102; {not assigned}
+         exit;
+       end;
+     end;
+   end;
+
+  { reset file handle }
+  filerec(f).handle:=UnusedHandle;
+
+  { convert filemode to filerec modes }
+  case (flags and 3) of
+    0 : filerec(f).mode:=fmInput;
+    1 : filerec(f).mode:=fmOutput;
+    2 : filerec(f).mode:=fmInout;
+  end;
+
+  { empty name is special }
+  if p[0]=#0 then begin
+    case filerec(f).mode of
+      fminput :
+        filerec(f).handle:=StdInputHandle;
+      fmappend,
+      fmoutput : begin
+        filerec(f).handle:=StdOutputHandle;
+        filerec(f).mode:=fmOutput; {fool fmappend}
+      end;
+    end;
+    exit;
+  end;
+
+  { rewrite (create a new file) }
+  { FIX ME: this will just create a new file, actual overwriting
+    seems to be a more complex endeavor... }
+  if (flags and $1000)<>0 then openMode:=Q_OPEN_NEW;
+
+  res:=io_open(p,openMode);
+
+  if res < 0 then
+    begin
+      Error2InOutRes(res);
+      filerec(f).mode:=fmClosed;
+      exit;
+    end
+  else
+    filerec(f).handle:=res;
+
+  { append mode }
+  if ((Flags and $100)<>0) and
+      (FileRec(F).Handle<>UnusedHandle) then begin
+    do_seekend(filerec(f).handle);
+    filerec(f).mode:=fmOutput; {fool fmappend}
+  end;
 end;
 
 

rtl/sinclairql/system.pp

@@ -32,7 +32,7 @@ interface
 
 {Platform specific information}
 const
-    LineEnding = #13#10;
+    LineEnding = #10;
     LFNSupport = false;
     CtrlZMarksEOF: boolean = false; (* #26 not considered as end of file *)
     DirectorySeparator = '\';
@@ -48,13 +48,13 @@ const
     AllFilesMask = '*.*';
 
     sLineBreak = LineEnding;
-    DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
+    DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
 
 const
     UnusedHandle    = $ffff;
-    StdInputHandle  = 0;
-    StdOutputHandle = 1;
-    StdErrorHandle  = $ffff;
+    StdInputHandle: longint = UnusedHandle;
+    StdOutputHandle: longint = UnusedHandle;
+    StdErrorHandle: longint = UnusedHandle;
 
 var
     args: PChar;
@@ -62,6 +62,10 @@ var
     argv: PPChar;
     envp: PPChar;
 
+    QCON: longint; // QDOS console
+    QSCR: longint; // QDOS screen
+    heapStart: pointer;
+
 
     {$if defined(FPUSOFT)}
 
@@ -119,6 +123,61 @@ var
     randseed:=0;
   end;
 
+procedure PrintStr(ch: longint; const s: shortstring);
+begin
+  io_sstrg(ch,-1,@s[1],ord(s[0]));
+end;
+
+procedure PrintStr2(ch: longint; const s: shortstring);
+var
+  i: smallint;
+begin
+  for i:=1 to ord(s[0]) do
+    io_sbyte(ch,-1,s[i]);
+end;
+
+procedure DebugStr(const s: shortstring); public name '_dbgstr';
+var
+  i: longint;
+begin
+  PrintStr($00010001,s);
+  for i:=0 to 10000 do begin end;
+end;
+
+{$ifdef FPC_QL_USE_TINYHEAP}
+procedure InitQLHeap;
+begin
+  HeapOrg:=nil;
+  HeapEnd:=nil;
+  FreeList:=nil;
+  HeapPtr:=nil;
+end;
+{$endif}
+
+{*****************************************************************************
+                        System Dependent Entry code
+*****************************************************************************}
+{ QL/QDOS specific startup }
+procedure SysInitQDOS;
+var
+  r: TQLRect;
+begin
+  stdInputHandle:=io_open('con_',Q_OPEN);
+  stdOutputHandle:=stdInputHandle;
+  stdErrorHandle:=stdInputHandle;
+  QCON:=stdInputHandle;
+
+  r.q_width:=512;
+  r.q_height:=256;
+  r.q_x:=0;
+  r.q_y:=0;
+
+  sd_wdef(stdInputHandle,-1,0,16,@r);
+  sd_clear(stdInputHandle,-1);
+
+//  QSCR:=io_open('scr_',Q_OPEN);
+end;
+
 {*****************************************************************************
                          System Dependent Exit code
 *****************************************************************************}
@@ -127,6 +186,12 @@ procedure haltproc(e:longint); external name '_haltproc';
 
 procedure system_exit;
 begin
+//  io_close(QCON);
+//  io_close(QSCR);
+  stdInputHandle:=UnusedHandle;
+  stdOutputHandle:=UnusedHandle;
+  stdErrorHandle:=UnusedHandle;
+
   haltproc(exitcode);
 end;
 
@@ -150,34 +215,24 @@ begin
   CheckInitialStkLen := StkLen;
 end;
 
-procedure PrintStr(const s: shortstring);
-begin
-  io_sstrg($00010001,-1,@s[1],ord(s[0]));
-end;
-
-procedure PrintStr2(const s: shortstring);
-var
-  i: smallint;
-begin
-  for i:=1 to ord(s[0]) do
-    io_sbyte($00010001,-1,s[i]);
-end;
-
 
 begin
   StackLength := CheckInitialStkLen (InitialStkLen);
 { Initialize ExitProc }
   ExitProc:=Nil;
+  SysInitQDOS;
 {$ifndef FPC_QL_USE_TINYHEAP}
 { Setup heap }
   InitHeap;
+{$else FPC_QL_USE_TINYHEAP}
+  InitQLHeap;
 {$endif FPC_QL_USE_TINYHEAP}
   SysInitExceptions;
 {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
   InitUnicodeStringManager;
 {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
 { Setup stdin, stdout and stderr }
-(*  SysInitStdIO;*)
+  SysInitStdIO;
 { Reset IO Error }
   InOutRes:=0;
 { Setup command line arguments }

tests/webtbs/tw38058.pp

@@ -67,5 +67,4 @@ begin
   Elems:=TConverter.Convert([my_a,my_c,my_e]);
   for Elem in Elems do
     write(Elem);
-  readln;
 end.