From 8342c502c558ecb39b6332cd8f377abdd7b95452 Mon Sep 17 00:00:00 2001 From: michael Date: Sat, 16 Dec 2017 15:55:10 +0000 Subject: [PATCH] * Initial check-in of pas2js changes git-svn-id: trunk@37749 - --- .gitattributes | 11 + utils/pas2js/dist/rtl.js | 739 ++++-- utils/pas2js/docs/translation.html | 2584 +++++++++++++++++++++ utils/pas2js/fpmake.lpi | 57 + utils/pas2js/fpmake.pp | 18 +- utils/pas2js/pas2js.cfg | 26 + utils/pas2js/pas2js.lpi | 50 +- utils/pas2js/pas2js.pp | 129 +- utils/pas2js/pas2js_defines.inc | 16 + utils/pas2js/pas2jscompiler.pp | 3177 ++++++++++++++++++++++++++ utils/pas2js/pas2jsfilecache.pp | 1097 +++++++++ utils/pas2js/pas2jsfileutils.pp | 676 ++++++ utils/pas2js/pas2jsfileutilsunix.inc | 206 ++ utils/pas2js/pas2jsfileutilswin.inc | 606 +++++ utils/pas2js/pas2jslogger.pp | 723 ++++++ utils/pas2js/pas2jspparser.pp | 157 ++ 16 files changed, 10046 insertions(+), 226 deletions(-) create mode 100644 utils/pas2js/docs/translation.html create mode 100644 utils/pas2js/fpmake.lpi create mode 100644 utils/pas2js/pas2js.cfg create mode 100644 utils/pas2js/pas2js_defines.inc create mode 100644 utils/pas2js/pas2jscompiler.pp create mode 100644 utils/pas2js/pas2jsfilecache.pp create mode 100644 utils/pas2js/pas2jsfileutils.pp create mode 100644 utils/pas2js/pas2jsfileutilsunix.inc create mode 100644 utils/pas2js/pas2jsfileutilswin.inc create mode 100644 utils/pas2js/pas2jslogger.pp create mode 100644 utils/pas2js/pas2jspparser.pp diff --git a/.gitattributes b/.gitattributes index b3698d18a9..08a14ac70e 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16936,9 +16936,20 @@ utils/pas2jni/writer.pas svneol=native#text/plain utils/pas2js/Makefile svneol=native#text/plain utils/pas2js/Makefile.fpc svneol=native#text/plain utils/pas2js/dist/rtl.js svneol=native#text/plain +utils/pas2js/docs/translation.html svneol=native#text/html +utils/pas2js/fpmake.lpi svneol=native#text/plain utils/pas2js/fpmake.pp svneol=native#text/plain +utils/pas2js/pas2js.cfg svneol=native#text/plain utils/pas2js/pas2js.lpi svneol=native#text/plain utils/pas2js/pas2js.pp svneol=native#text/plain +utils/pas2js/pas2js_defines.inc svneol=native#text/plain +utils/pas2js/pas2jscompiler.pp svneol=native#text/plain +utils/pas2js/pas2jsfilecache.pp svneol=native#text/plain +utils/pas2js/pas2jsfileutils.pp svneol=native#text/plain +utils/pas2js/pas2jsfileutilsunix.inc svneol=native#text/plain +utils/pas2js/pas2jsfileutilswin.inc svneol=native#text/plain +utils/pas2js/pas2jslogger.pp svneol=native#text/plain +utils/pas2js/pas2jspparser.pp svneol=native#text/plain utils/pas2js/samples/arraydemo.pp svneol=native#text/plain utils/pas2js/samples/fordemo.pp svneol=native#text/plain utils/pas2js/samples/fordowndemo.pp svneol=native#text/plain diff --git a/utils/pas2js/dist/rtl.js b/utils/pas2js/dist/rtl.js index 34d34df847..2e85cca02a 100644 --- a/utils/pas2js/dist/rtl.js +++ b/utils/pas2js/dist/rtl.js @@ -1,30 +1,10 @@ -/* - This file is part of the Free Pascal pas2js tool. - Copyright (c) 2017 Mattias Gaertner - - Basic RTL for pas2js programs. - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. -*/ - -var pas = {}; +var pas = {}; var rtl = { quiet: false, debug_load_units: false, - - m_loading: 0, - m_loading_intf: 1, - m_intf_loaded: 2, - m_loading_impl: 3, // loading all used unit - m_initializing: 4, // running initialization - m_initialized: 5, + debug_rtti: false, debug: function(){ if (rtl.quiet || !console || !console.log) return; @@ -40,97 +20,130 @@ var rtl = { rtl.debug('Warn: ',s); }, - isArray: function(a) { - return a instanceof Array; - }, - - isNumber: function(n){ - return typeof(n)=="number"; - }, - - isInteger: function(A){ - return Math.floor(A)===A; - }, - - isBoolean: function(b){ - return typeof(b)=="boolean"; - }, - - isString: function(s){ - return typeof(s)=="string"; - }, - - isObject: function(o){ - return typeof(o)=="object"; - }, - - isFunction: function(f){ - return typeof(f)=="function"; - }, - - isNull: function(o){ - return (o==null && typeof(o)=='object') || o==undefined; - }, - - isRecord: function(r){ - return (typeof(r)=="function") && (typeof(r.$create) == "function"); - }, - - isClass: function(c){ - return (typeof(o)=="object") && (o.$class == o); - }, - - isClassInstance: function(c){ - return (typeof(o)=="object") && (o.$class == Object.getPrototypeOf(o)); - }, - hasString: function(s){ return rtl.isString(s) && (s.length>0); }, - module: function(module_name, intfuseslist, code, impluseslist){ - if (rtl.debug_load_units) rtl.debug('rtl.module name="'+module_name+'" intfuses='+intfuseslist+' impluses='+impluseslist); + isArray: function(a) { + return Array.isArray(a); + }, + + isFunction: function(f){ + return typeof(f)==="function"; + }, + + isModule: function(m){ + return rtl.isObject(m) && rtl.hasString(m.$name) && (pas[m.$name]===m); + }, + + isImplementation: function(m){ + return rtl.isObject(m) && rtl.isModule(m.$module) && (m.$module.$impl===m); + }, + + isNumber: function(n){ + return typeof(n)==="number"; + }, + + isObject: function(o){ + var s=typeof(o); + return (typeof(o)==="object") && (o!=null); + }, + + isString: function(s){ + return typeof(s)==="string"; + }, + + getNumber: function(n){ + return typeof(n)==="number"?n:NaN; + }, + + getChar: function(c){ + return ((typeof(c)==="string") && (c.length===1)) ? c : ""; + }, + + getObject: function(o){ + return ((typeof(o)==="object") || (typeof(o)==='function')) ? o : null; + }, + + m_loading: 0, + m_loading_intf: 1, + m_intf_loaded: 2, + m_loading_impl: 3, // loading all used unit + m_initializing: 4, // running initialization + m_initialized: 5, + + module: function(module_name, intfuseslist, intfcode, impluseslist, implcode){ + if (rtl.debug_load_units) rtl.debug('rtl.module name="'+module_name+'" intfuses='+intfuseslist+' impluses='+impluseslist+' hasimplcode='+rtl.isFunction(implcode)); if (!rtl.hasString(module_name)) rtl.error('invalid module name "'+module_name+'"'); if (!rtl.isArray(intfuseslist)) rtl.error('invalid interface useslist of "'+module_name+'"'); - if (!rtl.isFunction(code)) rtl.error('invalid module code of "'+module_name+'"'); - if ((impluseslist!=undefined) && !rtl.isArray(impluseslist)) rtl.error('invalid implementation useslist of "'+module_name+'"'); + if (!rtl.isFunction(intfcode)) rtl.error('invalid interface code of "'+module_name+'"'); + if (!(impluseslist==undefined) && !rtl.isArray(impluseslist)) rtl.error('invalid implementation useslist of "'+module_name+'"'); + if (!(implcode==undefined) && !rtl.isFunction(implcode)) rtl.error('invalid implementation code of "'+module_name+'"'); if (pas[module_name]) - rtl.error('module "'+module_name+'" already registered'); + rtl.error('module "'+module_name+'" is already registered'); var module = pas[module_name] = { $name: module_name, $intfuseslist: intfuseslist, $impluseslist: impluseslist, $state: rtl.m_loading, - $code: code + $intfcode: intfcode, + $implcode: implcode, + $impl: null, + $rtti: Object.create(rtl.tSectionRTTI), + }; + module.$rtti.$module = module; + if (implcode) module.$impl = { + $module: module, + $rtti: module.$rtti, }; }, + exitcode: 0, + run: function(module_name){ - if (module_name==undefined) module_name='program'; - if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"'); - var module = pas[module_name]; - rtl.loadintf(module); - rtl.loadimpl(module); - if (module_name=='program'){ - if (rtl.debug_load_units) rtl.debug('running $main'); - pas.program.$main(); + function doRun(){ + if (!rtl.hasString(module_name)) module_name='program'; + if (rtl.debug_load_units) rtl.debug('rtl.run module="'+module_name+'"'); + rtl.initRTTI(); + var module = pas[module_name]; + if (!module) rtl.error('rtl.run module "'+module_name+'" missing'); + rtl.loadintf(module); + rtl.loadimpl(module); + if (module_name=='program'){ + if (rtl.debug_load_units) rtl.debug('running $main'); + var r = pas.program.$main(); + if (rtl.isNumber(r)) rtl.exitcode = r; + } } - return pas.System.ExitCode; + + if (rtl.showUncaughtExceptions) { + try{ + doRun(); + } catch(re) { + var errMsg = re.hasOwnProperty('$class') ? re.$class.$classname : ''; + errMsg += ((errMsg) ? ': ' : '') + (re.hasOwnProperty('fMessage') ? re.fMessage : re); + alert('Uncaught Exception : '+errMsg); + rtl.exitCode = 216; + } + } else { + doRun(); + } + return rtl.exitcode; }, loadintf: function(module){ - if (module.state>rtl.m_loading_intf) return; // already finished - if (rtl.debug_load_units) rtl.debug('loadintf: '+module.$name); - if (module.$state==rtl.m_loading_intf) + if (module.$state>rtl.m_loading_intf) return; // already finished + if (rtl.debug_load_units) rtl.debug('loadintf: "'+module.$name+'"'); + if (module.$state===rtl.m_loading_intf) rtl.error('unit cycle detected "'+module.$name+'"'); module.$state=rtl.m_loading_intf; // load interfaces of interface useslist rtl.loaduseslist(module,module.$intfuseslist,rtl.loadintf); // run interface - if (rtl.debug_load_units) rtl.debug('loadintf: run intf of '+module.$name); - module.$code(module.$intfuseslist,module); + if (rtl.debug_load_units) rtl.debug('loadintf: run intf of "'+module.$name+'"'); + module.$intfcode(module.$intfuseslist); // success module.$state=rtl.m_intf_loaded; // Note: units only used in implementations are not yet loaded (not even their interfaces) @@ -140,7 +153,7 @@ var rtl = { if (useslist==undefined) return; for (var i in useslist){ var unitname=useslist[i]; - if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.name+'" uses="'+unitname+'"'); + if (rtl.debug_load_units) rtl.debug('loaduseslist of "'+module.$name+'" uses="'+unitname+'"'); if (pas[unitname]==undefined) rtl.error('module "'+module.$name+'" misses "'+unitname+'"'); f(pas[unitname]); @@ -149,61 +162,106 @@ var rtl = { loadimpl: function(module){ if (module.$state>=rtl.m_loading_impl) return; // already processing - if (module.$state0){ + o = this[newinstancefnname](fnname,args); + } else { + o = Object.create(this); } - var a = []; - var count = dims[dim]; - a.length = count; - for(var i=0; iscrarray.length) end = scrarray.length; + if (index>=end) return []; + if (type===0){ + return srcarray.slice(index,end); + } else { + var a = []; + a.length = end-index; + rtl.arrayClone(type,srcarray,index,end,a,0); + return a; + } }, setCharAt: function(s,index,c){ return s.substr(0,index)+c+s.substr(index+1); }, + getResStr: function(mod,name){ + var rs = mod.$resourcestrings[name]; + return rs.current?rs.current:rs.org; + }, + createSet: function(){ var s = {}; for (var i=0; i newlen){ + return s.substring(0,newlen); + } else if (s.repeat){ + // Note: repeat needs ECMAScript6! + return s+' '.repeat(newlen-oldlen); + } else { + while (oldlen=width) return s; + if (s.repeat){ + // Note: repeat needs ECMAScript6! + return ' '.repeat(width-l) + s; + } else { + while (l2){ + return rtl.spaceLeft(d.toFixed(p),w); + } else { + // exponent width + var pad = ""; + var ad = Math.abs(d); + if (ad<1.0e+10) { + pad='00'; + } else if (ad<1.0e+100) { + pad='0'; + } + if (arguments.length<2) { + w=9; + } else if (w<9) { + w=9; + } + var p = w-8; + var s=(d>0 ? " " : "" ) + d.toExponential(p); + s=s.replace(/e(.)/,'E$1'+pad); + return rtl.spaceLeft(s,w); + } + }, + + initRTTI: function(){ + if (rtl.debug_rtti) rtl.debug('initRTTI'); + + // base types + rtl.tTypeInfo = { name: "tTypeInfo" }; + function newBaseTI(name,kind,ancestor){ + if (!ancestor) ancestor = rtl.tTypeInfo; + if (rtl.debug_rtti) rtl.debug('initRTTI.newBaseTI "'+name+'" '+kind+' ("'+ancestor.name+'")'); + var t = Object.create(ancestor); + t.name = name; + t.kind = kind; + rtl[name] = t; + return t; + }; + function newBaseInt(name,minvalue,maxvalue,ordtype){ + var t = newBaseTI(name,1 /* tkInteger */,rtl.tTypeInfoInteger); + t.minvalue = minvalue; + t.maxvalue = maxvalue; + t.ordtype = ordtype; + return t; + }; + newBaseTI("tTypeInfoInteger",1 /* tkInteger */); + newBaseInt("shortint",-0x80,0x7f,0); + newBaseInt("byte",0,0xff,1); + newBaseInt("smallint",-0x8000,0x7fff,2); + newBaseInt("word",0,0xffff,3); + newBaseInt("longint",-0x80000000,0x7fffffff,4); + newBaseInt("longword",0,0xffffffff,5); + newBaseInt("nativeint",-0x10000000000000,0xfffffffffffff,6); + newBaseInt("nativeuint",0,0xfffffffffffff,7); + newBaseTI("char",2 /* tkChar */); + newBaseTI("string",3 /* tkString */); + newBaseTI("tTypeInfoEnum",4 /* tkEnumeration */,rtl.tTypeInfoInteger); + newBaseTI("tTypeInfoSet",5 /* tkSet */); + newBaseTI("double",6 /* tkDouble */); + newBaseTI("boolean",7 /* tkBool */); + newBaseTI("tTypeInfoProcVar",8 /* tkProcVar */); + newBaseTI("tTypeInfoMethodVar",9 /* tkMethod */,rtl.tTypeInfoProcVar); + newBaseTI("tTypeInfoArray",10 /* tkArray */); + newBaseTI("tTypeInfoDynArray",11 /* tkDynArray */); + newBaseTI("tTypeInfoPointer",15 /* tkPointer */); + var t = newBaseTI("pointer",15 /* tkPointer */,rtl.tTypeInfoPointer); + t.reftype = null; + newBaseTI("jsvalue",16 /* tkJSValue */); + newBaseTI("tTypeInfoRefToProcVar",17 /* tkRefToProcVar */,rtl.tTypeInfoProcVar); + + // member kinds + rtl.tTypeMember = {}; + function newMember(name,kind){ + var m = Object.create(rtl.tTypeMember); + m.name = name; + m.kind = kind; + rtl[name] = m; + }; + newMember("tTypeMemberField",1); // tmkField + newMember("tTypeMemberMethod",2); // tmkMethod + newMember("tTypeMemberProperty",3); // tmkProperty + + // base object for storing members: a simple object + rtl.tTypeMembers = {}; + + // tTypeInfoStruct - base object for tTypeInfoClass and tTypeInfoRecord + var tis = newBaseTI("tTypeInfoStruct",0); + tis.$addMember = function(name,ancestor,options){ + if (rtl.debug_rtti){ + if (!rtl.hasString(name) || (name.charAt()==='$')) throw 'invalid member "'+name+'", this="'+this.name+'"'; + if (!rtl.is(ancestor,rtl.tTypeMember)) throw 'invalid ancestor "'+ancestor+':'+ancestor.name+'", "'+this.name+'.'+name+'"'; + if ((options!=undefined) && (typeof(options)!='object')) throw 'invalid options "'+options+'", "'+this.name+'.'+name+'"'; + }; + var t = Object.create(ancestor); + t.name = name; + this.members[name] = t; + this.names.push(name); + if (rtl.isObject(options)){ + for (var key in options) if (options.hasOwnProperty(key)) t[key] = options[key]; + }; + return t; + }; + tis.addField = function(name,type,options){ + var t = this.$addMember(name,rtl.tTypeMemberField,options); + if (rtl.debug_rtti){ + if (!rtl.is(type,rtl.tTypeInfo)) throw 'invalid type "'+type+'", "'+this.name+'.'+name+'"'; + }; + t.typeinfo = type; + this.fields.push(name); + return t; + }; + tis.addFields = function(){ + var i=0; + while(i + + pas2js - Translation of Pascal (Delphi/FPC) programs to JavaScript + + + + + + + + +
+

Overview

+ About pas2js
+ Command line parameters
+ Delphi and ObjFPC mode
+ Translating modules
+ Translating variables
+ Translating string
+ Translating resourcestrings
+ Translating types
+ Translating pointer
+ Translating record
+ Translating functions
+ Translating passing a parameter by reference
+ Translating nested functions
+ Translating for-loop
+ Translating repeat..until
+ Translating while..do
+ Translating with..do
+ Translating enums
+ Translating sets
+ Translating array type
+ Translating class type
+ Translating class-of type
+ Translating TObject.Free
+ Translating class interfaces
+ Translating attributes
+ Translating try..finally
+ Translating try..except
+ Translating function types
+ Calling JavaScript from Pascal
+ The asm block
+ The procedure modifier assembler
+ The procedure modifier external
+ The procedure modifier varargs
+ The var modifier external
+ The external modifier of class members
+ External classes
+ External class as ancestor
+ The JSValue type
+ Accessing JS object properties with the bracket accessor
+ RTTI - Run Time Type Information
+ Compiler directives
+ Other supported Pascal elements
+ Not supported elements
+ Creating source maps
+
+ +
+

About pas2js

+ pas2js is a compiler/transpiler to translate programs written in Pascal (subset of Delphi/ObjFPC syntax) + to JavaScript.
+ The goal is to use strong typing, while still be able to use low level whenever you choose.
+ The compiled Pascal functions can be used in DOM events or called by JavaScript.
+ pas2js is written completely in FPC, runs on many platforms like Windows, Mac and Linux and more. + It is built modular consisting of the following parts: +
    +
  • file cache - loading, caching files, converting to UTF-8
    • +
  • file resolver - handling search paths, finding used units and include files
    • +
  • scanner - reading tokens, handling compiler directives like $IfDef and $Include
    • +
  • parser - reading the tokens, checking syntax, creating Pascal nodes
    • +
  • resolver - resolving references, type checking and checking duplicate identifiers
    • +
  • use analyzer - finding unused identifiers, emit hints and warning
    • +
  • converter - translating Pascal nodes into JavaScript nodes
    • +
  • compiler - handling config files, parameters, compiling recursively all used units, writes js
    • +
  • command line interface - a small wrapper to embed the compiler into a console program
    • +
  • library and interface - a small wrapper to embed the compiler into a library
    • +
+ Each part is tested separately and is used by other FPC tools as well. For example + the scanner and parser are used by fpdoc too. Thus they are tested and extended by other + programmers, reducing greatly the work for developing pas2js. Consistency is kept by + several test suites, containing thousands of tests. +
+ +
+ Note: The modular structure allows to compile any parts or the whole compiler into an IDE addon (not yet started). +
+ +
+

Command line parameters

+ Most parameters work the same as their FPC equivalent. pas2js has some options of its own (see -J options). +
+Usage: pas2js <your.pas>
+Options:
+Put + after a boolean switch option to enable it, - to disable it
+  @<x>    : Read compiler options from file <x> in addition to the default pas2js.cfg
+  -B      : Rebuild all
+  -d<x>   : Defines the symbol <x>. Optional: -d<x>:=<value>
+  -i<x>   : Write information and halt. <x> is a combination of the following letters:
+    V     : Write short compiler version
+    W     : Write full compiler version
+  -F...   Set file names and paths:
+   -Fe<x> : Redirect output to <x>
+   -Fi<x> : Add <x> to include paths
+   -Fu<x> : Add <x> to unit paths
+   -FU<x> : Set unit output path to <x>
+  -I<x>   : Add <x> to include paths, same as -Fi
+  -J...  Extra options of pas2js
+   -Jc    : Write all JavaScript concatenated into the output file
+   -Ji<x> : Insert JS file <x> into main JS file. E.g. -Jirtl.js. Can be given multiple times.
+   -Jl    : lower case identifiers
+   -Jm    : generate source maps
+     -Jmsourceroot=<x> : use x as "sourceRoot", prefix URL for source file
+            names.
+     -Jmbasedir=<x> : write source file names relative to directory x.
+     -Jminclude : include Pascal sources in source map.
+     -Jm- : disable generating source maps
+   -Ju<x> : Add <x> to foreign unit paths. Foreign units are not compiled.
+   -Je<x> : Encode messages as <x>.
+     -Jeconsole : Console codepage. Default.
+     -Jesystem  : System codepage. On non Windows console and system are the same.
+     -Jeutf-8   : Unicode UTF-8. Default when using -Fe.
+  -l      : Write logo
+  -MDelphi: Delphi 7 compatibility mode
+  -MObjFPC: FPC's Object Pascal compatibility mode (default)
+  -NS<x>  : add <x> to namespaces. Namespaces with trailing - are removed.
+                  Delphi calls this flag "unit scope names".
+  -n      : Do not read the default config files
+  -o<x>   : Change main JavaScript file to <x>, "." means stdout
+  -O<x>   : Optimizations:
+    -O-   : Disable optimizations
+    -O1   : Level 1 optimizations (quick and debugger friendly)
+    -Oo<x> : Enable or disable optimization. The x is case insensitive:
+      -OoEnumNumbers[-] : write enum values as number instead of name. Default in -O1.
+      -OoRemoveNotUsedPrivates[-] : Default is enabled
+      -OoRemoveNotUsedDeclarations[-] : Default enabled for programs with -Jc
+      -OoRemoveNotUsedPublished[-] : Default is disabled
+  -P<x>   : Set target processor. Case insensitive:
+    -Pecmascript5  : default
+    -Pecmascript6
+  -S<x>   : Syntax options. <x> is a combination of the following letters:
+    c     : Support operators like C (*=,+=,/= and -=)
+    d     : Same as -Mdelphi
+    2     : Same as -Mobjfpc (default)
+  -T<x>   : Set target platform, case insensitive.
+    -Tbrowser : default
+    -Tnodejs  : add pas.run(), includes -Jc
+  -u<x>   : Undefines the symbol <x>
+  -v<x>   : Be verbose. <x> is a combination of the following letters:
+    e     : show errors (default)
+    w     : show warnings
+    n     : show notes
+    h     : show hints
+    i     : show info
+    l     : show line numbers
+    a     : show everything
+    0     : show nothing (except errors)
+    b     : show file names with full path
+    c     : show conditionals
+    t     : show tried/used files
+    d     : show debug notes and info, enables -vni
+    q     : show message numbers
+    x     : show used tools
+  -vm<x>,<y>: Do not show messages numbered <x> and <y>.
+  -?      : Show this help
+  -h      : Show this help
+
+
+ +
+

Delphi and ObjFPC mode

+

Delphi mode

+
    +
  • Defines macro DELPHI
    • +
  • Assigning a function to a function type variable does not require the @ operator. + For example, you can write either OnGetThing:=GetValue; or OnGetThing:=@GetValue;.
    • +
  • A function type variable reference without brackets is treated as a call. + For example: If OnGetThing is a variable of type function: integer + you can write: If OnGetThing=3 then ;.
    • +
  • You must use the @@ operator to get the procedure address (i.e. JS reference) of a procedure type variable. + For example instead of If OnClick=nil then ; you must use if @@OnClick=nil then ;.
    • +
  • Every procedure/method overload needs the 'overload' modifier.
    • +
+

ObjFPC mode

+ This the default mode of pas2js and is generally more strict than the Delphi mode, and allows some more operations. +
    +
  • Defines macro OBJFPC
    • +
  • Assigning a function to a function type variable requires the @ operator. + For example: OnGetThing:=@GetValue;.
    • +
  • A function type variable always needs brackets to be called. + For example: If OnGetThing is a variable of type function: integer + then this is allowed: If OnGetThing()=3 then ;. + While this gives an error: If OnGetThing=3 then ;.
    • +
  • You can compare a procedure type with nil. + For example If OnClick=nil then ;.
    • +
  • You can compare a procedure type with a procedure address (i.e. JS reference). + For example If OnClick=@OnFormClick then ;.
    • +
  • The procedure modifier 'overload' can be omitted when all overloads are + in one scope, e.g. a unit or a class. And if one procedure has such modifier + all procedures with same name and in same scope are overloads as well.
    • +
+
+ +
+

Translating modules

+ A Pascal Program is translated into the following JavaScript structure: + + + + + + + + + + + +
PascalJavaScript Structure, not code!
+
Program <unitname>;
+Implementation
+  [implementation section]
+Begin
+  [main code]
+End.
+
+ 		+
pas.<program>={
+  [implementation section],
+  $main: function() {
+    [main code]
+  }
+};
+
+
+
+ +
+ A Pascal Unit is translated into the following JavaScript structure: + + + + + + + + + + + +
PascalJavaScript Structure, not code!
+
Unit <unitname>;
+Interface
+  [interface section]
+Implementation
+  [implementation section]
+Initialization
+  [initialization section]
+End.
+
+ 		+
pas.<unitname>={
+  [interface section],
+  $impl: {
+    [implementation section],
+  },
+  $init: function() {
+    [initialization section]
+  }
+};
+
+
+ Note: The finalization section is not supported by pas2js.
+
+ +
+ To create and initialize the units in topological order the compiler translates + an Unit to the following JavaScript code: + + + + + + + + + + + +
PascalJavaScript
+
Unit <unitname>;
+Interface
+  [interface section]
+Implementation
+  [implementation section]
+Initialization
+  [initialization section]
+End.
+
+ 		+
rtl.module('<unitname>',
+  ['system',...other used units of the interface section...],
+  function(){
+    [interface section]
+    this.$init=function(){
+      [initialization section]
+    };
+  },
+  [...used units of the implementation section],
+  function(){
+    [implementation section]
+  }};
+
+
+
+ +
+ Here is a more detailed example to make it more clear: + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Uses Sysutils;
+var
+  dIntf: double;
+  sIntf: string = 'abc';
+procedure MyIntfProc;
+Implementation
+Uses Classes;
+Var dImpl:double;
+Procedure MyIntfProc;
+Begin
+  dImpl:=dIntf;
+End;
+Procedure MyImplProc;
+Begin
+  dImpl:=dIntf;
+End;
+Initialization
+End.
+
+ 		+
rtl.module("MyModule",
+["System","SysUtils"],
+function(){
+  var $mod = this;
+  var $impl = $mod.$impl;
+  this.dIntf = 0.0;
+  this.sIntf = "abc";
+  this.MyIntfProc = function(){
+    $impl.dImpl = $mod.dIntf;
+  };
+  this.$init = function() {
+  };
+},
+["Classes"],
+function(){
+  var $mod = this;
+  var $impl = $mod.$impl;
+  $impl.dImpl = 0.0;
+  $impl.MyImplProc = function() {
+    $impl.dImpl = $mod.dIntf;
+  };
+});
+
+
+ Notes: +
    +
  • Unit System is always loaded implicitely.
    • +
  • References to other units are translated to full path. For example + TObject is translated to pas.system.TObject
    • +
  • References to dotted unitnames, aka units with namespaces are translated + to pas["namespace.unitname"].
    • +
+
+ +
+

Translating variables

+ Variables are converted without type, because JavaScript lacks a clear type. + They are however always initialized, which helps JavaScript engines to optimize. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Uses Classes,Forms;
+const
+  c1:integer=3;
+  c2 = 'abc';
+  c3 = 234;
+  c4 = 12.45;
+  c5 = nil;
+var
+  v1:string;
+  v2,v3:double;
+  v4:byte=0;
+  v5:TForm;
+  v6:TIdentMapEntry;
+  v7:string='abcäöü';
+  v8:char='c';
+  v9:array of byte;
+Implementation
+End.
+
+ 		+
rtl.module("MyModule",
+["System","Classes","Forms"],
+function(){
+  this.c1 = 3;
+  this.c2 = "abc";
+  this.c3 = 234;
+  this.c4 = 12.45;
+  this.c5 = null;
+  this.v1 = "";
+  this.v2 = 0.0;
+  this.v3 = 0.0;
+  this.v4 = 0;
+  this.v5 = null;
+  this.v6 = new pas.Classes.TIdentMapEntry();
+  this.v7 = "abcäöü";
+  this.v8 = "c";
+  this.v9 = [];
+},
+[]);
+
+
+ + Notes: +
    +
  • Type casting a boolean to integer, gives 0 for false and 1 for true.
    • +
  • Type casting an integer to boolean, gives false for 0 and true otherwise.
    • +
  • A char is translated to a JS string, because JS lacks a native char type.
    • +
  • A char is a single JS char code. An UTF-16 codepoint can contain one or two char.
    • +
  • Integers overflows at runtime differ from Delphi/FPC, due to the double format. + For example adding var i: byte = 200; ... i:=i+100; will result in + i=300 instead of i=44 as in Delphi/FPC.
    • +
+
+ +
+

Translating string

+ Strings are translated to JavaScript strings. They are initialized with "" + and are never null.
+ There are no ShortString, AnsiString or RawByteString. + Unicodestring and Widestring are alias of String.
+ JavaScript strings are immutable, which means + that changing a single character in a string, creates a new string. So a s[2]:='c'; + is a slow operation in pas2js compared to Delphi/FPC.
+ Although pas2js creates .js files encoded as UTF-8 with BOM, JavaScript strings are + UTF-16 at runtime. Keep in mind that one UTF-16 codepoint can need two char, + and a visible glyph can need several codepoints. Same as in Delphi. +
+ +
+

Translating resourcestrings

+ Resourcestrings are translated to JS objects with original (org) and current value. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+resourcestring
+  rsCompiler = 'pas2js';
+var
+  s:string;
+Implementation
+initialization
+  s:=rsCompiler;
+End.
+
+ 		+
rtl.module("test1",["System"],function () {
+  var $mod = this;
+  this.s = "";
+  $mod.$resourcestrings = {rsCompiler: {org: "pas2js"}};
+  $mod.$init = function () {
+    $mod.s = rtl.getResStr(pas.test1,"rsCompiler");
+  };
+});
+
+
+
+ +
+

Translating Types

+ JavaScript type design has no declarative form, except for object types + (so-called prototypes). + That's why all the derivatives from simple Pascal types can not be translated. + The compiler ensures type safety at compile time though, which is a big plus + for using Pascal.
+ Complex Pascal types (classes, records, or arrays) are translated into + JavaScript objects or arrays respectively.
+
+ +
+

Translating pointer

+ A pointer is translated to a reference. It can be assigned a class, + a class reference, an array, a procedure var, a method var, a @proc address + or a @method address. There is no pointer arithmetic and no typed + pointers. You can find out its type using the functions isArray, + isClass, isClassRef, isCallback, etc of unit JS. +
+ +
+

Translating record type

+ A record is translated to a JavaScript object. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Type
+  TMyRecord = Record
+    i: integer;
+    s: string;
+    d: TDateTime;
+  End;
+Var
+  r, s: TMyRecord;
+Implementation
+Initialization
+  r.i := 123;
+  r:=s;
+  if r=s then ;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  this.TMyRecord = function(s) {
+    if (s){
+      this.i = s.i;
+      this.s = s.s;
+      this.d = s.d;
+    } else {
+      this.i = 0;
+      this.s = "";
+      this.d = 0.0;
+    };
+    this.$equal = function (b) {
+      return (this.i == b.i) && (this.s == b.i) && (this.d == b.d);
+    };
+  };
+  this.r = new this.TMyRecord();
+  $mod.$init = function() {
+    $mod.r.i=123;
+    $mod.r = new $mod.TMyRecord($mod.s);
+    if ($mod.r.$equal($mod.s)) ;
+  },
+},
+[]);
+
+
+
    +
  • The record variable creates a JavaScript object.
    • +
  • Variant records are not supported.
    • +
  • Supported: Assign, pass as argument, equal, not equal, array of record
    • +
  • Not yet implemented: Constants, pointer of record, advanced records, operators.
    • +
  • When assigning a record it is cloned. This is compatible with Delphi and FPC.
    • +
+
+ +
+

Translating functions

+ + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Function DoubleIt(n: integer): integer;
+Implementation
+Function DoubleIt(n: integer): integer;
+Begin
+  Result:=2*n;
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  this.DoubleIt = function(n){
+    Result = 0;
+    Result = 2*n;
+    return Result;
+  };
+},
+[]);
+
+
+ Notes: +
    +
  • Local variables become local JavaScript variables: var l = 0;.
    • +
  • Local constants become JavaScript variables in the unit/program implementation section.
    • +
  • Overloaded functions are given an unique name by appending $1, $2, ...
    + Overloading is always on. You don't need to add the overload modifier.
    • +
  • Supported: default values, local types, FuncName:=
    • +
+
+ +
+

Translating passing a parameter by reference

+ JavaScript lacks passing by reference. Instead a temporary object is created + with a get and set function. + That means changes within the procedure are immediately visible outside, compatible with Pascal. + + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+Procedure DoubleIt(var n: integer);
+Begin
+  n:=2*n;
+End;
+Function Doubling(n: integer): integer;
+Begin
+  DoubleIt(n);
+  Result:=n;
+End;
+Var
+  i: integer = 7;
+Begin
+  Doubling(i);
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  this.i = 7;
+  this.DoubleIt = function(n){
+    n.set(2*n.get());
+  };
+  this.Doubling = function(n){
+    var Result = 0;
+    DoubleIt({
+      get:function(){
+        return n
+      },
+      set:function(v){
+        n=v;
+      }
+    });
+    Result = n;
+    return n;
+  };
+  $mod.$main = function(){
+    Doubling($mod.i);
+  }
+},
+[]);
+
+
+ + When the passed value is from another context, the context is passed too: + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+Procedure DoubleIt(var n: integer);
+Begin
+  n:=2*n;
+End;
+Var
+  i: integer = 7;
+Begin
+  DoubleIt(i);
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  this.i = 7;
+  this.DoubleIt = function(n){
+    n.set(2*n.get());
+  };
+  $mod.$main = function(){
+    DoubleIt({
+        p:$mod,
+        get:function(){
+          return this.p.i
+        },
+        set:function(v){
+          this.p.i=v;
+        }
+      });
+  }
+},
+[]);
+
+
+ + Notes: +
    +
  • Contrary to Delphi/FPC it is allowed to pass a property to a var/out parameter.
    • +
+
+ +
+

Translating nested functions

+ A nested function is translated to a local variable. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Function SumNNumbers(n, Adder: integer): integer;
+Implementation
+Function SumNNumbers(n, Adder: integer): integer;
+
+  Function Add(k: integer): integer;
+  Begin
+    if k=1 then
+      Result:=1
+    else
+      Result:=Add(k-1)+Adder;
+  End;
+
+Begin
+  Result:=Add(n);
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  this.DoubleIt = function(n,Adder){
+    Result = 0;
+    var Add = function(k) {
+      Result = 0;
+      if (k==1) {
+        Result = 1;
+      } else {
+        Result = Add(k-1)+Adder;
+      }
+      return Result;
+    };
+    Result = Add(n);
+    return Result;
+  };
+},
+[]);
+
+
+ Note: You can assign a nested procedure to a procedure variable. A nested + procedure of a method can be assigned to a method variable.
+ JavaScript preserves the current local scope, including references to the + local variables of parent functions. Local types and constants belong to the + unit scope (singleton).
+ When a method has nested functions, the compiler adds a local var Self. +
+ +
+

Translating for-loops

+ The JavaScript for-loop executes the end expression every iteration, while + Pascal only executes it once. Therefore a local variable is introduced. + If the loop is not entered at all, the variable is not touched. If the loop + was entered the variable contanis the last value. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Function SumNNumbers(n: integer): integer;
+Implementation
+Function SumNNumbers(n: integer): integer;
+Var
+  i, j: integer;
+Begin
+  j:=0;
+  For i:=1 To n Do
+  Begin
+    j:=j+i;
+  End;
+  if i<1 then j:=1;
+  Result:=j;
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  this.SumNNumbers=function(n){
+    Result = 0;
+    j = 0;
+    for (var $l1 = 1, $le2 = n; $l1 <= $le2; $l1++) {
+      i = $l1;
+      j = j + i;
+    };
+    if (i<1) j=1;
+    Result = j;
+    return Result;
+  };
+},
+[]);
+
+
+ Note: The after-loop decrement is only added if i is read after the loop.
+
+ +
+

Translating repeat..until

+ The repeat..until is translated to a do{}while(). + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Function SumNNumbers(n: integer): integer;
+Implementation
+Function SumNNumbers(n: integer): integer;
+Var
+  i, j: integer;
+Begin
+  j:=0;
+  i:=0;
+  Repeat
+    i:=i+1;
+    j:=j+i;
+  Until i>=n;
+  Result:=j;
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  this.SumNNumbers=function(n){
+    Result = 0;
+    j = 0;
+    i = 0;
+    do{
+      i = (i + 1);
+      j = (j + i);
+    } while (!(i>=n));
+    Result = j;
+    return Result;
+  };
+},
+[]);
+
+
+
+ +
+

Translating while..do

+ + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Function SumNNumbers(n: integer): integer;
+Implementation
+Function SumNNumbers(n: integer): integer;
+Var
+  i, j: integer;
+Begin
+  j:=0;
+  i:=0;
+  While i<n Do Begin
+    i:=i+1;
+    j:=j+i;
+  End;
+  Result:=j;
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  this.SumNNumbers=function(n){
+    var Result = 0;
+    var j = 0;
+    var i = 0;
+    while(i<n){
+      i = (i + 1);
+      j = (j + i);
+    };
+    Result = j;
+    return Result;
+  };
+},
+[]);
+
+
+
+ +
+

Translating case..do

+ Although JavaScript has something similar in form of the "switch" statement, + it lacks ranges and is on current JS engines often slower than "if-else". + Therefore a case..of is translated to if..else. + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+Var
+  i: integer;
+Begin
+  case i of
+    1: ;
+    2: i:=3;
+  else
+    i:=4;
+  end;
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  this.i = 0;
+  $mod.$main=function(n){
+    $tmp1 = $mod.i;
+    if ($tmp1 == 1){
+    } else if ($tmp1 == 2) {
+      i=3;
+    } else {
+      i=4;
+    }
+  };
+},
+[]);
+
+
+
+ +
+

Translating with..do

+ JavaScript has a with, but it is slow and deprecated. + Instead a temporary variable is used: + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+type
+  TClassA = class
+    i: integer;
+  end;
+
+procedure DoIt;
+
+Implementation
+
+procedure DoIt;
+begin
+  with TClassA.Create do
+    i:=3;
+end;
+
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  rtl.createClass($mod, "TClassA", pas.System.TObject, function () {
+    this.$init = function () {
+      this.i = 0;
+    };
+  });
+  this.DoIt = function(){
+    var $with1 = $mod.TClassA.$create("Create");
+    $with1.i = 3;
+  };
+},
+[]);
+
+
+ Note: If the with-expression is already a local variable no new variable is + created. This is Delphi/FPC compatible. +
+ +
+

Translating enums

+ Enum values are translated to numbers. The enum type is translated to an + object containing a mapping from name to number and number to name. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+type
+  TMyEnum = (
+    Red,
+    Green,
+    Blue);
+var
+  e: TMyEnum = Blue;
+
+procedure DoIt;
+
+Implementation
+
+procedure DoIt;
+begin
+  e := Green;
+end;
+
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  this.TMyEnum = {
+    "0":"Red",
+    Red:0,
+    "1":"Green",
+    Green:1,
+    "2":"Blue",
+    Blue:2
+    };
+  this.e = $mod.TMyEnum.Blue;
+  this.DoIt = function(){
+    $mod.e = $mod.TMyEnum.Green;
+  };
+},
+[]);
+
+
+
    +
  • Supported: ord(), low(), high(), pred(), succ(), type cast number to enum.
    • +
  • With optimization level -O1 the compiler uses numbers instead of names.
    • +
  • Not yet implemented: custom values for enum values.
    • +
+
+ +
+

Translating sets

+ A set s is translated to a JavaScript object, where for each included enum + holds s.enumvalue==true. + This allows arbitrary large sets and the in operator is fast. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+type
+  TColor = (Red, Green, Blue);
+  TColors = set of TColor;
+
+procedure DoIt;
+
+Implementation
+
+procedure DoIt;
+var
+  c: TColor;
+  S, T: TColors;
+  b: boolean;
+begin
+  S:=T;
+  b:=Red in S;
+  Include(S,Blue);
+  Exclude(S,Blue);
+  S:=S+T;
+  S:=S-[Red,c];
+  b:=c in [Red..Blue];
+end;
+
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  this.TColor = {
+    "0":"Red",
+    Red:0,
+    "1":"Green",
+    Green:1,
+    "2":"Blue",
+    Blue:2
+    };
+  $mod.DoIt = function(){
+    var c = 0;
+    var S = {};
+    var T = {};
+    var b = false;
+    S = rtl.refSet(T);
+    b = $mod.TColor.Red in S;
+    S = rtl.includeSet(S,$mod.TColor.Blue);
+    S = rtl.excludeSet(S,$mod.TColor.Blue);
+    S = rtl.unionSet(S,T);
+    S = rtl.diffSet(S,rtl.createSet($mod.TColor.Red,c));
+    b = c in rtl.createSet(null,$mod.TColor.Red,$mod.TColor.Blue);
+  };
+},
+[]);
+
+
+
    +
  • Supported: +
      +
    • Include
      • +
    • Exclude
      • +
    • literal
      • +
    • literal range, e.g. [EnumA..EnumB], ['a'..'z']
      • +
    • union +
      • +
    • difference -
      • +
    • intersect *
      • +
    • symmetrical difference ><
      • +
    • equal =
      • +
    • unequal <>
      • +
    • subset <=
      • +
    • superset >=
      • +
    • set of anonymous enum type: set of (enum1,enum2,...)
      • +
    +
    • +
  • Not supported: set of char, set of boolean
    • +
  • There is no optimization yet for small sets like in Delphi/FPC.
    • +
  • Assigning a set or passing the set as an argument only creates a + reference and marks the set as shared. + When a shared set is altered with Include/Exclude a new set is + created (copy on write).
    • +
  • Passing a set as an argument might clone the set. + Use the const modifier for parameters whenever possible.
    • +
  • Constant sets in expressions (e.g. if c in ['a'..'z'] then) + are not yet optimized and created every time. Create a const to avoid this.
    • +
+
+ +
+

Translating array type

+ All arrays are translated into JavaScript arrays.
+ Contrary to Delphi/FPC dynamic arrays are + not reference counted and do not copy on write. That means if you pass an + array to a procedure and change an element, the original array is changed. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Type
+  TIntArr = Array of integer;
+  TObjArr = Array of TObject;
+  TRec = record c: char; end;
+  TRecArr = Array of TRec;
+Procedure Test;
+Implementation
+Procedure Test;
+Var
+  IntArr: TIntArr = (1,2,3);
+  ObjArr: TObjArr;
+  RecArr: TRecArr;
+Begin
+  IntArr:=nil;
+  SetLength(IntArr,4);
+  IntArr[2]:=2;
+  IntArr[1]:=length(IntArr);
+  SetLength(ObjArr,5);
+  SetLength(RecArr,2,TRec);
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  this.Test = function(){
+    this.TRec = function(s){
+      if (s){
+        this.c = s.c;
+      } else {
+        this.c = "";
+      };
+      this.$equal = function(b){
+        return (this.c == b.c);
+      };
+    };
+    this.IntArr = [1,2,3];
+    this.ObjArr = [];
+    this.RecArr = [];
+    this.Test = function(){
+      $mod.IntArr = [];
+      rtl.arraySetLength($mod.IntArr,4,0);
+      $mod.IntArr[2] = 2;
+      $mod.IntArr[1] = $mod.IntArr.length;
+      rtl.setArrayLength($mod.ObjArr,5,null);
+      rtl.setArrayLength($mod.RecArr,2,$mod.TRec);
+    }
+  };
+},
+[]);
+
+
+ Notes: +
    +
  • Supported features of dynamic arrays: SetLength(), Length(), equal/notequal nil, low(), high(), + assigned(), concat(), copy(), insert(), delete(), multi dimensional, array of record
    • +
  • Dynamic array constants. E.g. const a: array of byte = (1,2)
    • +
  • Supported features of static arrays: length(), low(), high(), assigned(), concat(), copy(), const, except const records
    • +
  • Open arrays are implemented as dynamic arrays.
    • +
  • Calling Concat() with only one array simply returns the array + (no cloning). Calling it with multiple arrays creates a clone. + This is Delphi 10.1 compatible.
    • +
  • In Delphi/FPC an empty array is nil. In JS it can be null or []. + For compatibility comparing an array with nil checks for length(a)>0.
    • +
  • function Assigned(array): boolean results true iff length(array)>0.
    • +
  • Not yet implemented: array of const.
    • +
  • function copy(array,start=0,count=max): array
    • +
  • procedure insert(item,var array,const position)
    • +
  • procedure delete(var array,const start,count)
    • +
+
+ +
+

Translating class type

+ Classes are implemented using Object.create and some rtl magic. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Type
+  TClassA = Class(TObject)
+  Public
+    i: integer;
+    Procedure Add(a: integer);
+  End;
+var
+  ObjA: TClassA;
+Implementation
+Procedure TClassA.Add(a: integer);
+Begin
+  i:=i+a;
+End;
+Initialization
+  ObjA:=TClassA.Create;
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  rtl.createClass($mod,"TClassA",pas.System.TObject,function(){
+    this.$init = function () {
+      this.i = 0;
+    };
+    this.Add = function(a){
+      this.i = this.i + a;
+    };
+  });
+  this.ObjA = null;
+  $mod.$init = function(){
+    $mod.ObjA = $mod.TClassA.$create("Create");
+  };
+},
+[]);
+
+
+ Notes: +
    +
  • Each class and each instance is an JS object.
    • +
  • Each class has a globally unique JS object, created by rtl.createClass.
    • +
  • Self is never nil.
    • +
  • The method TObject.Free is using compiler magic. See Translating TObject.Free.
    • +
  • Class.$class is a reference to the class itself.
    • +
  • Class.$ancestor is a reference to the ancestor class.
    • +
  • A class has c.$ancestor == Object.getPrototypeOf(c).
    • +
  • A class instance has o.$class == Object.getPrototypeOf(o).
    • +
  • Class.$classname is the short name. E.g. TClassA.$classname == 'TClassA'.
    • +
  • Class.$name is the long name. E.g. TClassA.$name == 'MyModule.TClassA'.
    • +
  • Class.$unitname is the unit name. E.g. TClassA.$unitname == 'MyModule'.
    • +
  • The "is"-operator is implemented using "isPrototypeOf". Note that "instanceof" cannot be used, because classes are JS objects.
    • +
  • The "as" operator is implemented as rtl.as(Object,Class).
    • +
  • Supported: constructor, destructor, private, protected, public, + strict private, strict protected, class vars, class methods, external methods, + virtual, override, abstract, call inherited, assigned(), type cast, + overloads, reintroduce, sealed class
    • +
  • Property: +
      +
    • References are replaced by getter/setter.
      • +
    • Supported: argument lists, default property, class property, stored modifier, index modifier.
      • +
    • Class property getter/setter are not static as in Delphi.
      • +
    • The Index modifier supports any constant, e.g. a string, while + Delphi only allows an ordinal (longint). -2147483648 is not a special + number in pas2js. Overriding a property with an index property is allowed + in Delphi and pas2js.
      • +
    +
    • +
+
+ +
+

Translating class-of type

+ A class-of is a reference to a class. See above about translating class. + + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Type
+  TBird = Class(TObject)
+  Public
+    Class var Count: integer;
+    Class Procedure Add(a: integer); virtual;
+  End;
+  TBirds = class of TBird;
+
+  TPigeon = Class(TBird)
+  Public
+    Class Procedure Add(a: integer); override;
+  End;
+
+var
+  BirdType: TBirds;
+Implementation
+Class Procedure TBird.Add(a: integer);
+Begin
+  Count:=Count+a;
+End;
+Class Procedure TPigeon.Add(a: integer);
+Begin
+  inherited Add(a+1);
+End;
+Initialization
+  BirdType:=TPigeon;
+  BirdType.Add(1);
+End.
+
+ 		+
rtl.module("MyModule",
+["System"],
+function(){
+  var $mod = this;
+  rtl.createClass($mod,"TBird",pas.System.TObject,function () {
+    this.Count = 0;
+    this.Add = function (a) {
+      this.Count = this.Count + a;
+    };
+  });
+  rtl.createClass($mod,"TPigeon",$mod.TBird,function () {
+    this.Add = function (a) {
+      $mod.TBird.Add.call(this,a + 1);
+    };
+  });
+  $mod.$init = function(){
+    $mod.BirdType = $mod.TPigeon;
+    $mod.BirdType.Add(1);
+  };
+},
+[]);
+
+
+ Note that this in a class method is the class itself.
+
+ Notes:
+
    +
  • Contrary to Delphi/FPC the "is" operator works with class-of.
    • +
+
+ +
+

Translating TObject.Free

+ In Delphi/FPC AnObject.Free checks if Self is nil, then calls the destructor + and frees the memory, without changing the reference. + In JavaScript however calling a method with AnObject=nil causes a crash. + And memory cannot be freed explicitely. Memory is only + freed if all references are gone (e.g. set to null).
+ Therefore pas2js adds code to call the destructor and sets the variable to nil:
+
    +
  • Obj.Free on a local variable or argument is translated to + Obj = rtl.freeLoc(Obj);.
    • +
  • Obj.Free on a non local variable is translated to + rtl.free(this,"Obj");.
    • +
  • Not supported: Freeing a property or function result.
    + For example List[i].Free gives a compiler error. The property + setter might create side effects, which would be incompatible to Delphi/FPC. +
    • +
+ Notes: +
    +
  • If the destructor raises an exception, the variable is not set to nil. + This is compatible to Delphi/FPC, where the memory is not freed in this case.
    • +
  • Alternatively you can use FreeAndNil, which first changes + the variable to nil and then calls the destructor.
    • +
+
+ +
+

Translating class interfaces

+ Class interfaces are not yet implemented. To make porting code easier there + is a {$modeswitch ignoreinterfaces}, that ignores interface declarations + and the class interface list. +
+ +
+

Translating attributes

+ Attributes are not yet implemented. To make porting code easier there + is a {$modeswitch ignoreattributes}, that ignores attributes. +
+ +
+

Translating try..finally

+ JavaScript has the same, so it translates straight forward. +
+ +
+

Translating try..except

+ + + + + + + + + + + +
PascalJavaScript
+
Unit MyModule;
+Interface
+Uses SysUtils, Math, JS;
+Function DoIt(n: integer): double;
+Implementation
+Function DoIt(n: integer): double;
+var E: Exception;
+Begin
+  try
+    Result:=double(7.0)/n;
+    if not IsFinite(Result) then
+      if n=0 then
+        raise EZeroDivide.Create
+      else
+        raise EOverflow.Create;
+  except
+    on EZeroDivide do Result:=0.0;
+    on E2: EOverflow do Result:=0.0;
+    else
+      raise EAbort.Create('Something other: '+String(JS.JSExceptObject));
+  end;
+End;
+End.
+
+ 		+
rtl.module("MyModule",
+["System","SysUtils"],
+function(){
+  this.DoIt=function(n){
+    Result = 0;
+    var E = null;
+    try{
+      Result = 7.0 / n;
+      if (!IsFinite(Result)){
+        if (n==0){
+          throw pas.SysUtils.EZeroDivide.$create("Create");
+        } else {
+          throw pas.SysUtils.EOverflow.$create("Create");
+        };
+      };
+    }catch($e){
+      if (pas.SysUtils.EZeroDivide.isPrototypeOf($e)){
+        Result = 0.0;
+      } else if (pas.SysUtils.EOverflow.isPrototypeOf($e)){
+        var E2 = $e;
+        Result = 0.0;
+      } else {
+        throw pas.SysUtils.EAbort.$create("Create",["Something other: "+(""+$e)]);
+      }
+    }
+    return Result;
+  };
+},
+[]);
+
+
+ Notes: +
    +
  • Division by zero does not raise an exception in JavaScript. Instead it results in Infinity, except for 0/0 which results in NaN.
    • +
  • There is no ExceptObject in SysUtils.
    • +
  • When calling external functions keep in mind that JS allows to + throw (raise) any value, often a string.
    + You can access the current except value via JSExceptValue in unit JS.
    + Note that this is only valid inside the catch-block. The compiler will not warn, + if you use it outside.
    • +
+ +
+

Translating function type

+ JavaScript functions work like Delphi's "reference to function", which + means like closures. Normal functions and nested functions can simply be + assigned to variables. + A Pascal method needs this to be the class or class instance.
+ Note that bind cannot be used, because it does not support the equal operator. + Instead a wrapper is created: + + + + + + + + + + + +
PascalJavaScript
+
Unit UnitA;
+Program MyModule;
+type
+  TMyMethod = procedure(n: integer) of object;
+  TBird = class
+    procedure DoIt(n: integer); virtual; abstract;
+  end;
+  TMyProc = procedure(n: integer);
+procedure DoSome(n: integer);
+begin
+end;
+var
+  m: TMyMethod;
+  Bird: TBird;
+  p: TMyProc;
+Begin
+  m:=@Bird.DoIt;
+  m(3);
+  p:=@DoSome;
+  p(4);
+End.
+
+ 		+
rtl.module("program",
+["System","UnitA"],
+function(){
+  var $mod = this;
+  rtl.createClass($mod,"TBird",pas.System.TObject,function(){
+    this.DoIt = function (n) {
+    };
+  });
+  this.DoSome = function (n) {
+  };
+  this.m = null;
+  this.Bird = null;
+  this.p = null;
+  $mod.$main = function() {
+    $mod.m = rtl.createCallback($mod.Bird,"DoIt");
+    $mod.m(3);
+    $mod.p = $mod.DoSome;
+    $mod.p(4);
+  };
+},
+[]);
+
+rtl = {
+  ...
+  createCallback: function(scope, fn){
+    var cb = function(){
+      return scope[fn].apply(scope,arguments);
+    };
+    cb.scope = scope;
+    cb.fn = fn;
+    return cb;
+  },
+  ...
+
+
+ Notes: +
    +
  • You can assign a nested procedure to procedure variable. + You don't need and you must not add the FPC "is nested" modifier.
    • +
+
+ +
+

Calling JavaScript from Pascal

+ Pas2js allows to write low level functions and/or access a JavaScript library + with the following possibilities: +
+ +
+

The asm block

+ The asm block is pure JavaScript, that is copied directly into the generated .js file. + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+var
+  s: string;
+Begin
+  s = 'Hello World!';
+  Asm
+    console.log(s);
+  End;
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  this.s = '';
+  $mod.$main = function(){
+    $mod.s = "Hello World!";
+    console.log(s);
+  };
+},
+[]);
+
+
+ + Notes: +
    +
  • The block is indented to produce more readable JS code. + All lines are indented or unindented the same amount, i.e. sub indentation is kept.
    • +
  • The compiler does neither parse, nor check the syntax of the JS.
    • +
  • The compiler does not know what Pascal identifiers are used by the + asm-block and might remove them, if no Pascal code is using them. + To make sure that an identifier is kept, add some dummy code like + if MyVar=0 then;
    • +
  • Accessing an interface, program or library identifier:
    +
      +
    • From inside the module you can use $mod.Identifier.
      • +
    • Otherwise use the fully qualified path pas.Unitname.Identifier.
      • +
    +
    • +
  • Accessing an implementation identifier:
    +
      +
    • From inside the unit you can use $impl.Identifier.
      • +
    • Otherwise use the path pas.Unitname.$impl.Identifier.
      • +
    +
    • +
  • Accessing a class instance member (field, procedure, function, + constructor, destructor) from a method of the class: use this.Identifier. + Inside a nested function of a method you use the Self.Identifier. +
    • +
  • Accessing a class member (class var, class procedure, class function) + from a method of the class: for writing use this.$class.Identifier, + for reading you can omit the $class.
    • +
  • Accessing a class member (class var, class procedure, class function) + from a class method of the class: use this.Identifier.
    • +
  • Access to Properties must use the getter/setter.
    • +
  • When calling a Pascal method, make sure the this is correct: +
      +
    • A class method (e.g. class function, class procedure) + needs the class as this.
      + Wrong: aCar.DoIt(params,...)
      + Correct: aCar.$class.DoIt(params,...)
      +
      • +
    +
    • +
  • Calling a Pascal function from a HTML/DOM-element: + For example to call a function when user clicks a DOM element you can + assign a function to the onclick property. This will call + the function with this set to the DOM element.
    + Pascal methods needs a wrapper to set this to the + instance. Examples: +
      +
    • An unit function: DOMElement.onclick = $mod.DoIt;
      • +
    • An implementation function: DOMElement.onclick = $impl.DoIt;.
      • +
    • A method: DOMElement.onclick = this.DoIt.bind(this);
      • +
    • A class function/procedure: DOMElement.onclick = this.DoIt.bind(this.$class);
      • +
    • A nested function: DOMElement.onclick = DoIt;.
      • +
    +
    • + +
+
+ +
+

The procedure modifier assembler

+ You can write pure JavaScript functions like this: + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+
+Procedure Log(const s: string); assembler;
+Asm
+  console.log(s);
+end;
+
+Begin
+  Log('Hello World!');
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  this.Log = function(s){
+    console.log(s);
+  };
+  $mod.$main = function(){
+    $mod.Log("Hello World!");
+  };
+},
+[]);
+
+
+ + See also asm. +
+ +
+

The procedure modifier external

+ The procedure modifier external requires a string constant and tells the + compiler to replace a reference with this string value. The value is not + checked for JS syntax. + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+Procedure ConsoleLog(const s: string); external name 'console.log';
+// Note: an external procedure has no begin..end block
+Begin
+  ConsoleLog('Hello World!');
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  $mod.$main = function(){
+    console.log("Hello World!");
+  };
+},
+[]);
+
+
+
+ +
+

The procedure modifier varargs

+ Appending the varargs modifier to a procedure allows to pass arbitrary + more parameters to a function. To access these non typed arguments use + either JSArguments from unit JS or an asm..end block. + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+uses JS;
+function Sum(b: boolean): longint; varargs;
+var i: longint;
+begin
+  if b then
+    asm
+      for (var i=0; i<arguments.length; i++) Result+=arguments[i];
+    end
+  else
+    for i:=0 to JSArguments.length-1 do
+      Result:=Result+longint(JSArguments[i]);
+end;
+var
+  i: integer;
+Begin
+  i:=Sum(true,2,4,6); // i=12
+  i:=Sum(false,2,4,6); // i=12
+End.
+
+ 		+
rtl.module("program",
+["System","JS"],
+function(){
+  var $mod = this;
+  this.Sum = function(b){
+    var Result = 0;
+    var i = 0;
+    if (b){
+      for (var i=0; i<arguments.length; i++) Result+=arguments[i];
+    } else {
+      for (var $l1 = 1, $le2 = argumens.length; $l1 <= $le2; $l1++){
+        $i = $l1;
+        Result = Result + arguments[i];
+      }
+    }
+    return Result;
+  };
+  this.i = 0;
+  $mod.$main = function(){
+    $mod.i = $mod.Sum(true,2,4,6);
+    $mod.i = $mod.Sum(false,2,4,6);
+  };
+},
+[]);
+
+
+ The above example defines a function Sum, that requires the first parameter to + be a boolean and then an arbitrary number of parameters. The compiler does not + type check the other parameters, so you can pass anything readable. +
+ +
+

The var modifier external

+ The var modifier external allows to use a JavaScript variable or constant. + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+var
+  EulersNumber: Double; external name 'Math.E';
+  d: double;
+Begin
+  d:=EulersNumber;
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  this.d = 0.0;
+  $mod.$main = function(){
+    $mod.d = Math.E;
+  };
+},
+[]);
+
+
+
+ +
+

The external modifier of class members

+ The method modifier external works as the procedure modifier, except + it uses the scope of the class or instance.
+ The field modifier external works as the var modifier, except + it uses the scope of the class or instance.
+ Requires the modeswitch externalclass. + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+{$modeswitch externalclass}
+type
+  TWrapper = class
+  private
+    // let's assume this object has a $Handle and an $id
+  public
+    Id: NativeInt; external name '$Id';
+    function GetState(typ: longint): NativeInt; external name '$Handle.GetState';
+    procedure DoIt;
+  end;
+procedure TWrapper.DoIt;
+begin
+  Id := GetState(4);
+end;
+var
+  W: TWrapper;
+Begin
+  W.Id := 2;
+  W.GetState(3);
+End.
+
+ 		+
rtl.module("program",
+["System"],
+function(){
+  var $mod = this;
+  rtl.createClass($mod, "TWrapper", pas.System.TObject, function () {
+    this.DoIt = function(){
+      this.$Id = this.$Handle.GetState(4);
+    };
+  });
+  this.W = null;
+  $mod.$main = function(){
+    $mod.W.$Id = 2;
+    $mod.W.$Handle.GetState(3);
+  };
+},
+[]);
+
+
+
+ +
+

External classes

+ pas2js introduces a new class modifier "external name", which makes + the whole class external. + External classes allow to easily declare Pascal wrappers for JavaScript + objects and function objects.
+ They need the modeswitch externalclass in front of the class.
+ An external class is not a TObject and has none of its methods.
+ All members are external. If you omit the external modifier the + external name is the member name. Keep in mind that JS is case sensitive.
+ Destructors are not allowed.
+ Constructors are only allowed with the name New and a call + translates to new ExtClass(params). + Properties work the same as with Pascal classes, i.e. are replaced by Getter/Setter.
+ + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+{$modeswitch externalclass}
+type
+  TJSDate = class external name 'Date'
+  private
+    function getYear: NativeInt;
+    procedure setYear(const AValue: NativeInt);
+  public
+    constructor New;
+    constructor New(const MilliSecsSince1970: NativeInt);
+    class function now: NativeInt;
+    property Year: NativeInt read getYear write setYear;
+  end;
+var
+  d: TJSDate;
+Begin
+  d:=TJSDate.New;
+  d.Year:=d.Year+1;
+End.
+
+ 		+
rtl.module("program",["System"],function () {
+  var $mod = this;
+  this.d = null;
+  $mod.$main = function () {
+    $mod.d = new Date();
+    $mod.d.setYear($mod.d.getYear() + 1);
+  };
+});
+
+
+ Notes: +
    +
  • Any class instance can be type casted to any root class.
    • +
  • A Pascal class can descend from an external class.
    • +
  • You can define a class-of external class and the is and as + operators work similar.
    • +
  • Class variables work as in JavaScript. That means, each descendant and each + instance can have its own value. For example TExtA.Value might be + different from InstanceExtA.Value. Setting InstanceExtA.Value + does not change TExtA.Value.
    • +
  • Class functions and class procedures are allowed, but can only be called via the class, not via an instance.
    + For example you can call the class function TJSString.fromCharCode(), but you cannot + call aJSString.fromCharCode().
    • +
  • An external class can descend from another external class.
    • +
+
+ +
+

External class as ancestor

+ A Pascal class can descend from an external class.
+ The methods AfterConstruction and BeforeDestruction + are called if they exist.
+ New instances are created by default with Object.create(ancestorclass).
+ You can override this, by providing a
+ class function NewInstance(fnname: string; const paramsarray): TPasClass; virtual;. + This method is called to create a new instance and before calling the constructor. + The name is arbitrary, but the function must be the first non private, + non external, virtual class function with the class as result type.
+ + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+{$modeswitch externalclass}
+type
+  TExtA = class external name 'ExtA'
+  end;
+  TMyB = class(TExtA)
+  protected
+    class function NewInstance(fnname: string; const paramarray): TMyB; virtual;
+  end;
+class function TMyB.NewInstance(fnname: string; const paramarray): TMyB;
+Begin
+  asm
+  Result = Object.create(ExtA);
+  end;
+End;
+
+Begin
+End.
+
+ 		+
rtl.module("program",["System"],function () {
+  var $mod = this;
+  rtl.createClassExt($mod, "TMyB", ExtA, "NewInstance", function () {
+    this.$init = function () {
+    };
+    this.$final = function () {
+    };
+    this.NewInstance = function (fnname, paramarray) {
+      var Result = null;
+      Result = Object.create(ExtA);
+      return Result;
+    };
+  });
+  $mod.$main = function () {
+  };
+});
+
+
+
+ +
+

The JSValue type

+ Pas2js introduces a new type JSValue, which works similar to a JS variable. + You can assign almost any value to it and it can be type casted to many types. + JSValue is useful for JS wrappers, when a variable can have multiple types. + And it can be used for containers storing arbitrary data, e.g. a list of JSValue.
+ Key features:
+
    +
  • A JSValue variable initial value is undefined.
    • +
  • Operators: =, <>
    • +
  • type casting a JSValue to ... +
      +
    • Integer: Math.floor(aJSValue) Note: may return NaN
      • +
    • Boolean: !(aJSValue == false) Note: works for numbers too, 0==false
      • +
    • Double: rtl.getNumber(aJSValue) Note: typeof(n)=="number"?n:NaN;
      • +
    • String: ""+aJSValue
      • +
    • Char: rtl.getChar(aJSValue) Note: ((typeof(c)!="string") && (c.length==1)) ? c : ""
      • +
    • class instance or class-of: rtl.getObject() Note: checks for type "object"
      • +
    • enum type
      • +
    • pointer
      • +
    +
    • +
  • A JSValue in a conditional expressions If aJSValue then, while aJSValue do, + repeat until aJSValue has the same meaning as in JS: the condition is + true, if the value is not undefined, false, null, NaN, 0, ''. + Note that new Boolean(false) is not null and the condition is true. +
    • +
  • function Assigned(V: jsvalue): boolean returns true if
    + (V!=undefined) && (V!=null) && (!rtl.isArray(V) || (V.length > 0))
    • +
  • function StrictEqual(const A: jsvalue; const B): boolean
    • +
  • function StrictInequal(const A: jsvalue; const B): boolean
    • +
  • Any array can be assigned to an array of jsvalue.
    • +
  • The unit JS provides many utility functions for JSValue, like hasString, + hasValue, isBoolean, isNumber, isInteger, isObject, isClass, isClassInstance, etc..
    • +
+
+ +
+

Accessing JS object properties with the bracket accessor

+ Pas2js allows to define index properties that map directly to the JS object properties. + For example the default property of TJSObject allows to get and set the + properties of an object. For example TJSObject(AnObject)['Name']:=Value;
+ Another example is the default property of TJSArray, that allows access via integers + aTJSArray[3]:=Value;
+ To define your own bracket accessor define a normal index property and define + the getter/setter as external name '[]'.
+ Here is an example for a read only accessor: + + + + + + + + + + + +
PascalJavaScript
+
Program MyModule;
+{$modeswitch externalclass}
+type
+  TExtA = class external name 'ExtA'
+  private
+    function GetItems(Index: integer): String; external name '[]';
+  public
+    property Items[Index: integer]: String read GetItems; default;
+  end;
+var
+  Obj: TExtA;
+  s: String;
+Begin
+  ... get Obj from somewhere ...
+  s:=Obj[2];
+End.
+
+ 		+
rtl.module("program",["System"],function () {
+  var $mod = this;
+  this.Obj = undefined;
+  this.s = "";
+  $mod.$main = function () {
+    $mod.s = Obj[2];
+  };
+});
+
+
+ Notes: +
    +
  • A property can have a mix of normal accessor and bracket accessor. + For example a bracket accessor as getter and a normal function as setter.
    • +
+
+ +
+

RTTI - Run Time Type Information

+ The RTTI provides access to the type data of all published properties, + fields and methods. The type data provides similar information as Delphi/FPC, + but the internals are very different. Delphi/FPC uses pointers, + variant records and fake static arrays, which have no equivalent in JS. + Instead pas2js uses external classes. For example: + 
+    TTypeInfo = class external name 'rtl.tTypeInfo'
+    public
+      Name: String external name 'name';
+      Kind: TTypeKind external name 'kind';
+    end;
+    TTypeInfoClass = class of TTypeInfo;
+
+    TTypeInfoInteger = class external name 'rtl.tTypeInfoInteger'(TTypeInfo)
+    public
+      MinValue: NativeInt external name 'minvalue';
+      MaxValue: NativeInt external name 'maxvalue';
+      OrdType : TOrdType external name 'ordtype';
+    end;
+
+ The typeinfo function works on type, var, const and property identifiers. + By default it returns a pointer. If the typinfo unit is used it returns the + appropiate TTypeInfo. For instance typeinfo(integer) returns + a TTypeInfoInteger.
+ Typeinfo of a var or const returns the typeinfo of its + type, not of its current runtime value. The exception is a class and class-of instance + variable (e.g. var o: TObject; ... typeinfo(o)), which returns the + typeinfo of the current runtime value. + If o is null it will give a JS error.
+ Local types (i.e. inside a procedure) do not have typeinfo.
+ Open array parameters are not yet supported.
+
+ + +
+

Compiler directives

+ In config files: +
    +
  • #IFDEF macroname
    • +
  • #IFNDEF macroname
    • +
  • #IF expression - same as $if, except only defines
    • +
  • #ELSEIF
    • +
  • #ELSE
    • +
  • #ENDIF
    • +
  • #ERROR text
    • +
+ In source files: +
    +
  • {$Define MacroName}: defines macro MacroName with value '1'.
    • +
  • {$Define MacroName:=value}: defines macro MacroName with custom value.
    • +
  • {$Undef MacroName}: undefines macro MacroName.
    • +
  • {$IfDef MacroName}: if MacroName is not defined, skip to next $Else or $EndIf. Can be nested.
    • +
  • {$IfNDef MacroName}: as $IfDef, except negated.
    • +
  • {$If boolean expression}: if expression evaluates to true + (not '0'), skip to next $Else or $EndIf. Can be nested.
    + Supported functions and operators:
    +
      +
    • macro - replaced by its value, a simple define has value '1'
      • +
    • defined(macro) - '1' if defined, '0' otherwise
      • +
    • undefined(macro) - as not defined(macro)
      • +
    • option(letter) - same as {$IFOpt letter+}
      • +
    • not - first level of precedence
      • +
    • *, /, div, mod, and, shl, shr - second level of precedence
      • +
    • +, -, or, xor - third level of precedence
      • +
    • =, <>, <, >, <=, >= - fourth level of precedence
      • +
    • If the operands can be converted to numbers they are combined as numbers, otherwise as strings.
      • +
    + Not supported functions and operators:
    +
      +
    • defined(Pascal identifier), undefined(Pascal identifier)
      • +
    • declared(Pascal identifier)
      • +
    • in operator
      • +
    +
    • +
  • {$IfOpt Letter+,-}: if expression evaluates to true (not '0'), skip to next $Else or $EndIf. Can be nested.
    • +
  • {$Else}: If previous $IfDef was skipped, execute next block, otherwise skip.
    • +
  • {$ElseIf boolean expression}: As $Else, except with an extra expression like $if to test. There can be multiple $elseif.
    • +
  • {$EndIf}: ends an $IfDef block
    • +
  • {$mode delphi} or {$mode objfpc}: Same as -Mdelphi or -Mobjfpc, but only for this unit. You can use units of both modes in a program. If present must be at the top of the unit, or after the module name.
    • +
  • {$modeswitch externalclass}: allow declaring external classes
    • +
  • {$macro on|off} enables macro replacements. Only macros with a custom value are replaced. Macros are never replaced inside directives.
    • +
  • {$I filename} or {$include filename} - insert include file
    • +
  • {$ERROR text}
    • +
  • {$WARNING text}
    • +
  • {$NOTE text}
    • +
  • {$HINT text}
    • +
  • {$M+}, {$TypeInfo on}: switches default visibility for class members from public to published
    • +
+ Defines: +
    +
  • PASJS
    • +
  • PAS2JS_FULLVERSION - major*1000+minor*100+release, e.g. 1.2.3 = 10203
    • +
  • Target platform: BROWSER, NODEJS
    • +
  • Target processor: ECMAScript5, ECMAScript6, ECMAScript=5
    • +
  • Mode: DELPHI, OBJFPC
    • +
+
+ +
+

Numbers

+ JavaScript only supports double. All Pascal number types and enum values + are mapped to this. A double supports integers from
+ MinInteger = -$10000000000000;
+ MaxInteger = $fffffffffffff;
+ MinDouble = 5.0e-324;
+ MaxDouble = 1.7e+308;
+
+ Intrinsic integer types: +
    +
  • Byte - unsigned 8-bit
    • +
  • ShortInt - signed 8-bit
    • +
  • Word - unsigned 16-bit
    • +
  • SmallInt - signed 16-bit
    • +
  • LongWord - unsigned 32-bit
    • +
  • LongInt - signed 32-bit
    • +
  • NativeUInt - unsigned 52-bit
    • +
  • NativeInt - signed 53-bit
    • +
+ Notes: +
    +
  • Division by zero does not raise an exception. 0/0 results in NaN, positive/0 is Infinity, negative/0 is -Infinity.
    • +
  • NaN<>NaN
    • +
  • Overflows work differently. For example in Delphi adding 100 to a byte of 200 gives 300 and $ff = 44, while in pas2js it gives 300, which is not a byte anymore.
    • +
  • Math.isNan(double) tests for NaN. Otherwise false. isNan(Infinity)=false.
    • +
  • Math.isFinite(double) tests if not NaN, positive or negative infinity.
    • +
  • Math.isInfinite(double) tests if positive or negative infinity.
    • +
  • For more functions see unit Math.
    • +
  • To make porting easier Single is defined in the system unit as alias of + double, but gives a warning. Since using higher precision might give + unexpected results you should check every place.
    • +
+
+ +
+

Other supported Pascal elements

+
    +
  • break, continue, exit, exit()
    • +
  • chr, ord
    • +
  • alias type, but not type alias type
    • +
  • inc()/dec() to += -=
    • +
  • Converts "a div b" to "Math.floor(a / b)"
    • +
  • and, or, xor, not: logical and bitwise
    • +
  • Name conflicts with JS identifiers are automatically fixed by changing case. + For example a Pascal function "apply" is renamed to "Apply".
    • +
  • The built-in procedure str works with boolean, integer, float and enumvalue.
    + Additionally there is str function, that takes an arbitrary number of + arguments and returns a concatenated string. It supports string as parameter too. + For example s:=str(i,' ',d:1:5).
    + Width and precision is supported. str(i:10) will add spaces to the left to fill up to 10 characters. + str(aDouble:1:5) returns a string in decimal format with 5 digits for the fraction.
    • +
+
+ +
+

Not supported elements

+
    +
  • Advanced records
    • +
  • Anonymous functions
    • +
  • Array of const
    • +
  • Attributes
    • +
  • Currency
    • +
  • Enumeration for..in..do
    • +
  • Enums with custom values
    • +
  • Generics
    • +
  • Global properties
    • +
  • Futures
    • +
  • Helpers for types, classes, records
    • +
  • Inline
    • +
  • Interfaces
    • +
  • Library
    • +
  • Nested types in class
    • +
  • Objects
    • +
  • Operator overloading
    • +
  • Pointer of record
    • +
  • Pointer arithmetic
    • +
  • Resources
    • +
  • RTTI extended, $RTTI
    • +
  • Runtime checks: Overflow -Co, $Q
    • +
  • Runtime checks: Range -Cr, $R
    • +
  • Runtime checks: Typecast -CR
    • +
  • Scoped enums
    • +
  • Set of char, boolean, custom range
    • +
  • Type alias, e.g. type TTranslateString = type string;
    • +
  • Var Absolute modifier
    • +
  • Variant records
    • +
  • Variants
    • +
+
+ +
+

JavaScript Version

+ Code generation depending on -P option: +
    +
  • ECMAScript5
    • +
  • ECMAScript6: using 0b for binary literals, and 0o for octal literals
    • +
+
+ +
+

Creating source maps

+ Source maps are files telling the browser what JavaScript comes from which + original source (e.g. Pascal file), similar to debug information in FPC/Delphi.
+ In 2017 FireFox and Chrome supports source maps.
+ You can enable generating source map files by using the -Jm option.
+ The compiler generates one module.js.map file for every generated module.js file. + The last line of the .js file contains the line
+ //# sourceMappingURL=module.js.map
+ telling the browser where to find the source map.
+ The source map contains references to the Pascal files and included .js + files (e.g. -Jirtl.js) relative to the location of the source map. + Note that if the Pascal file lies in a parent directory, the relativ path + contains '../'. You can change the base directory of the relative paths by using + the option -Jmbasedir=<x>. For example -JmC:\www\pas + creates paths relative to C:\www\pas.
+ You can set the base URL, where the browser finds the Pascal sources, by passing + the -Jmsourceroot=<x> option. For example + -Jmsourceroot=http://www.yoursite.com/pas/. The browser prepends this + to the source map filenames when downloading the original source files + (e.g. the .pas files).
+ You can include the whole Pascal sources in the source map using the option + -Jminclude.
+
+ To show the generated mapping for each line you can use the tool fpc/packages/fcl-js/examples/srcmapdump.
+
+ + + + diff --git a/utils/pas2js/fpmake.lpi b/utils/pas2js/fpmake.lpi new file mode 100644 index 0000000000..0e7515e276 --- /dev/null +++ b/utils/pas2js/fpmake.lpi @@ -0,0 +1,57 @@ + + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="1"> + <Unit0> + <Filename Value="fpmake.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="fpmake"/> + </Target> + <SearchPaths> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/utils/pas2js/fpmake.pp b/utils/pas2js/fpmake.pp index 5ee6f4f21e..ab670e6077 100644 --- a/utils/pas2js/fpmake.pp +++ b/utils/pas2js/fpmake.pp @@ -9,7 +9,7 @@ procedure add_pas2js(const ADirectory: string); Var P : TPackage; - T : TTarget; + PT,T : TTarget; begin With Installer do @@ -21,6 +21,7 @@ begin P.HomepageURL := 'www.freepascal.org'; P.Description := 'Convert pascal sources to javascript.'; P.Email := 'michael@freepascal.org'; + Defaults.Options.Add('-Sc'); P.NeedLibC:= false; P.Directory:=ADirectory; @@ -28,8 +29,19 @@ begin P.Dependencies.Add('fcl-js'); P.Dependencies.Add('fcl-passrc'); P.Dependencies.Add('pastojs'); - - T:=P.Targets.AddProgram('pas2js.pp'); + T:=P.Targets.AddUnit('pas2jscompiler.pp'); + T:=P.Targets.AddUnit('pas2jsfilecache.pp'); + T:=P.Targets.AddUnit('pas2jsfileutils.pp'); + T.Dependencies.AddInclude('pas2jsfileutilsunix.inc',AllUnixOSes); + T.Dependencies.AddInclude('pas2jsfileutilswin.inc',AllWindowsOSes); + T:=P.Targets.AddUnit('pas2jslogger.pp'); + T:=P.Targets.AddUnit('pas2jspparser.pp'); + PT:=P.Targets.AddProgram('pas2js.pp'); + PT.Dependencies.AddUnit('pas2jscompiler'); + PT.Dependencies.AddUnit('pas2jsfileutils'); + PT.Dependencies.AddUnit('pas2jsfilecache'); + PT.Dependencies.AddUnit('pas2jslogger'); + PT.Dependencies.AddUnit('pas2jspparser'); end; end; diff --git a/utils/pas2js/pas2js.cfg b/utils/pas2js/pas2js.cfg new file mode 100644 index 0000000000..1f0d77709f --- /dev/null +++ b/utils/pas2js/pas2js.cfg @@ -0,0 +1,26 @@ +# +# Config file for pas2js compiler +# + +# not yet implemented: -d is the same as #DEFINE +# not yet implemented: -u is the same as #UNDEF + +# Write always a nice logo ;) +-l + +# Display Hints, Warnings and Notes +-vwnh +# If you don't want so much verbosity use +#-vw + +-Fu$CfgDir/../rtl +-Fu$CfgDir/../packages/fcl-base +-Fu$CfgDir/../packages/fcl-db +-Fu$CfgDir/../packages/fpcunit + +#IFDEF nodejs +-Jirtl.js +#ENDIF + +# end. + diff --git a/utils/pas2js/pas2js.lpi b/utils/pas2js/pas2js.lpi index 3b5baddf2c..ac095736b4 100644 --- a/utils/pas2js/pas2js.lpi +++ b/utils/pas2js/pas2js.lpi @@ -4,11 +4,9 @@ <Version Value="10"/> <General> <Flags> - <SaveOnlyProjectUnits Value="True"/> + <MainUnitHasUsesSectionForAllUnits Value="False"/> <MainUnitHasCreateFormStatements Value="False"/> <MainUnitHasTitleStatement Value="False"/> - <SaveJumpHistory Value="False"/> - <SaveFoldState Value="False"/> </Flags> <SessionStorage Value="InProjectDir"/> <MainUnit Value="0"/> @@ -16,9 +14,6 @@ <UseAppBundle Value="False"/> <ResourceType Value="res"/> </General> - <i18n> - <EnableI18N LFM="False"/> - </i18n> <BuildModes Count="1"> <Item1 Name="Default" Default="True"/> </BuildModes> @@ -28,17 +23,51 @@ <RunParams> <local> <FormatVersion Value="1"/> + <CommandLineParams Value="/home/michael/pinc.pp"/> </local> </RunParams> - <Units Count="2"> + <Units Count="9"> <Unit0> <Filename Value="pas2js.pp"/> <IsPartOfProject Value="True"/> </Unit0> <Unit1> - <Filename Value="fppas2js.pp"/> + <Filename Value="pas2jscompiler.pp"/> <IsPartOfProject Value="True"/> + <UnitName Value="Pas2jsCompiler"/> </Unit1> + <Unit2> + <Filename Value="pas2jslogger.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Pas2jsLogger"/> + </Unit2> + <Unit3> + <Filename Value="pas2jsfileutils.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Pas2jsFileUtils"/> + </Unit3> + <Unit4> + <Filename Value="pas2jsfilecache.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Pas2jsFileCache"/> + </Unit4> + <Unit5> + <Filename Value="pas2jspparser.pp"/> + <IsPartOfProject Value="True"/> + <UnitName Value="Pas2jsPParser"/> + </Unit5> + <Unit6> + <Filename Value="pas2js_defines.inc"/> + <IsPartOfProject Value="True"/> + </Unit6> + <Unit7> + <Filename Value="pas2jsfileutilsunix.inc"/> + <IsPartOfProject Value="True"/> + </Unit7> + <Unit8> + <Filename Value="pas2jsfileutilswin.inc"/> + <IsPartOfProject Value="True"/> + </Unit8> </Units> </ProjectOptions> <CompilerOptions> @@ -50,6 +79,11 @@ <IncludeFiles Value="$(ProjOutDir)"/> <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> </SearchPaths> + <Parsing> + <SyntaxOptions> + <AllowLabel Value="False"/> + </SyntaxOptions> + </Parsing> </CompilerOptions> <Debugging> <Exceptions Count="3"> diff --git a/utils/pas2js/pas2js.pp b/utils/pas2js/pas2js.pp index 3e15e5f30c..5aaab87f8a 100644 --- a/utils/pas2js/pas2js.pp +++ b/utils/pas2js/pas2js.pp @@ -1,92 +1,77 @@ -{ - This file is part of the Free Component Library (FCL) - Copyright (c) 2014 by Michael Van Canneyt +{ Author: Mattias Gaertner 2017 mattias@freepascal.org - Pascal to Javascript converter program. - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - **********************************************************************} - -{$mode objfpc} -{$h+} + Abstract: + Command line interface for the pas2js compiler. +} program pas2js; +{$mode objfpc}{$H+} + uses - sysutils, classes, pparser, fppas2js, pastree, jstree, jswriter, pasresolver; + {$IFDEF UNIX} + cthreads, cwstring, + {$ENDIF} + Pas2jsFileUtils, Classes, SysUtils, CustApp, + Pas2jsCompiler; Type - { TConvertPascal } + { TPas2jsCLI } - TConvertPascal = Class(TComponent) - Procedure ConvertSource(ASource, ADest : String); + TPas2jsCLI = class(TCustomApplication) + private + FCompiler: TPas2jsCompiler; + FWriteOutputToStdErr: Boolean; + protected + procedure DoRun; override; + public + constructor Create(TheOwner: TComponent); override; + destructor Destroy; override; + property Compiler: TPas2jsCompiler read FCompiler; + property WriteOutputToStdErr: Boolean read FWriteOutputToStdErr write FWriteOutputToStdErr; end; - -{ TConvertPascal } - -Procedure TConvertPascal.ConvertSource(ASource, ADest: String); - -Var - C : TPas2JSResolver; - M : TPasModule; - CV : TPasToJSConverter; - JS : TJSElement; - W : TJSWriter; - +procedure TPas2jsCLI.DoRun; +var + ParamList: TStringList; + i: Integer; begin - W:=nil; - M:=Nil; - CV:=Nil; - C:=TPas2JSResolver.Create; + ParamList:=TStringList.Create; try - M:=ParseSource(C,ASource,'','',[poUseStreams]); - CV:=TPasToJSConverter.Create; - JS:=CV.ConvertPasElement(M,C); - If JS=nil then - Writeln('No result') - else - begin - W:=TJSWriter.Create(ADest); - W.Options:=[woUseUTF8,woCompactArrayLiterals,woCompactObjectLiterals,woCompactArguments]; - W.IndentSize:=2; - W.WriteJS(JS); - end + for i:=1 to ParamCount do + ParamList.Add(Params[i]); + try + Compiler.Run(ParamStr(0),GetCurrentDirUTF8,ParamList); + except + on E: ECompilerTerminate do ; + end; finally - W.Free; - CV.Free; - M.Free; - C.Free; + ParamList.Free; + Compiler.Log.CloseOutputFile; end; + // stop program loop + Terminate; // Keep ExitCode! end; -Var - Src,Dest : String; - +constructor TPas2jsCLI.Create(TheOwner: TComponent); begin - Src:=Paramstr(1); - Dest:=ParamStr(2); - if Dest='' then - Dest:=ChangeFileExt(Src,'.js'); - With TConvertPascal.Create(Nil) do - try - ConvertSource(Src,Dest); - finally - Free; - end; - With TStringList.Create do - try - LoadFromFile(Dest); - Writeln(Text); - finally - Free; - end; + inherited Create(TheOwner); + StopOnException:=True; + FCompiler:=TPas2jsCompiler.Create; +end; + +destructor TPas2jsCLI.Destroy; +begin + FreeAndNil(FCompiler); + inherited Destroy; +end; + +var + Application: TPas2jsCLI; +begin + Application:=TPas2jsCLI.Create(nil); + Application.Run; + Application.Free; end. diff --git a/utils/pas2js/pas2js_defines.inc b/utils/pas2js/pas2js_defines.inc new file mode 100644 index 0000000000..dd4e265138 --- /dev/null +++ b/utils/pas2js/pas2js_defines.inc @@ -0,0 +1,16 @@ + +{$inline on} +{$IFDEF Windows} + {$define CaseInsensitiveFilenames} + {$define HasUNCPaths} +{$ENDIF} +{$IFDEF darwin} + {$define CaseInsensitiveFilenames} +{$ENDIF} +{$IF defined(CaseInsensitiveFilenames) or defined(darwin)} + {$DEFINE NotLiteralFilenames} // e.g. HFS+ normalizes file names +{$ENDIF} + +{$DEFINE UTF8_RTL} + + diff --git a/utils/pas2js/pas2jscompiler.pp b/utils/pas2js/pas2jscompiler.pp new file mode 100644 index 0000000000..595bf1e5a8 --- /dev/null +++ b/utils/pas2js/pas2jscompiler.pp @@ -0,0 +1,3177 @@ +{ Author: Mattias Gaertner 2017 mattias@freepascal.org + +Abstract: + TPas2jsCompiler is the wheel boss of the pas2js compiler. + It can be used in a command line program or compiled into an application. + +Compiler-ToDos: + Warn if -Ju and -Fu intersect + -Fa<x>[,y] (for a program) load units <x> and [y] before uses is parsed + Add Windows macros, see InitMacros. + add options for names of globals like 'pas' and 'rtl' + +FileCache: + uses 'in' +} +unit Pas2jsCompiler; + +{$mode objfpc}{$H+} +{$inline on} + +interface + +uses + Classes, SysUtils, AVL_Tree, contnrs, + PScanner, PParser, PasTree, PasResolver, PasUseAnalyzer, PasResolveEval, + jstree, jswriter, FPPas2Js, FPPJsSrcMap, + Pas2jsFileUtils, Pas2jsLogger, Pas2jsFileCache, Pas2jsPParser; + +const + VersionMajor = 0; + VersionMinor = 8; + VersionRelease = 39; + VersionExtra = '+beta'; + DefaultConfigFile = 'pas2js.cfg'; + +//------------------------------------------------------------------------------ +// Messages +const + nOptionIsEnabled = 101; sOptionIsEnabled = 'Option "%s" is %s'; + nSyntaxModeIs = 102; sSyntaxModeIs = 'Syntax mode is %s'; + nMacroDefined = 103; sMacroDefined = 'Macro defined: %s'; + nUsingPath = 104; sUsingPath = 'Using %s: "%s"'; + nFolderNotFound = 105; sFolderNotFound = '%s not found: "%s"'; + nNameValue = 106; sNameValue = '%s: "%s"'; + nReadingOptionsFromFile = 107; sReadingOptionsFromFile = 'Reading options from file "%s"'; + nEndOfReadingConfigFile = 108; sEndOfReadingConfigFile = 'End of reading config file "%s"'; + nInterpretingFileOption = 109; sInterpretingFileOption = 'interpreting file option "%s"'; + nSourceFileNotFound = 110; sSourceFileNotFound = 'source file not found "%s"'; + nFileIsFolder = 111; sFileIsFolder = 'expected file, but found directory "%s"'; + nConfigFileSearch = 112; sConfigFileSearch = 'Configfile search: %s'; + nHandlingOption = 113; sHandlingOption = 'handling option "%s"'; + nQuickHandlingOption = 114; sQuickHandlingOption = 'quick handling option "%s"'; + nOutputDirectoryNotFound = 115; sOutputDirectoryNotFound = 'output directory not found: "%s"'; + nUnableToWriteFile = 116; sUnableToWriteFile = 'Unable to write file "%s"'; + nWritingFile = 117; sWritingFile = 'Writing file "%s" ...'; + nCompilationAborted = 118; sCompilationAborted = 'Compilation aborted'; + nCfgDirective = 119; sCfgDirective = 'cfg directive "%s": %s'; + nUnitCycle = 120; sUnitCycle = 'Unit cycle found %s'; + nOptionForbidsCompile = 121; sOptionForbidsCompile = 'Option -Ju forbids to compile unit "%s"'; + nUnitNeedsCompileDueToUsedUnit = 122; sUnitsNeedCompileDueToUsedUnit = 'Unit "%s" needs compile due to used unit "%s"'; + nUnitNeedsCompileDueToOption = 123; sUnitsNeedCompileDueToOption = 'Unit "%s" needs compile due to option "%s"'; + nUnitNeedsCompileJSMissing = 124; sUnitsNeedCompileJSMissing = 'Unit "%s" needs compile, js file missing "%s"'; + nUnitNeedsCompilePasHasChanged = 125; sUnitsNeedCompilePasHasChanged = 'Unit "%s" needs compile, Pascal file has changed, js is "%s"'; + nParsingFile = 126; sParsingFile = 'Parsing "%s" ...'; + nCompilingFile = 127; sCompilingFile = 'Compiling "%s" ...'; + nExpectedButFound = 128; sExpectedButFound = 'Illegal unit name: Expected "%s", but found "%s"'; + nLinesInFilesCompiled = 129; sLinesInFilesCompiled = '%s lines in %s files compiled, %s sec'; + nTargetPlatformIs = 130; sTargetPlatformIs = 'Target platform is %s'; + nTargetProcessorIs = 131; sTargetProcessorIs = 'Target processor is %s'; + nMessageEncodingIs = 132; sMessageEncodingIs = 'Message encoding is %s'; + nUnableToTranslatePathToDir = 133; sUnableToTranslatePathToDir = 'Unable to translate path "%s" to directory "%s"'; + nSrcMapSourceRootIs = 134; sSrcMapSourceRootIs = 'source map "sourceRoot" is %s'; + nSrcMapBaseDirIs = 135; sSrcMapBaseDirIs = 'source map "local base directory" is %s'; + +//------------------------------------------------------------------------------ +// Options +type + TP2jsCompilerOption = ( + coSkipDefaultConfigs, + coBuildAll, + coShowLogo, + coShowErrors, + coShowWarnings, + coShowNotes, + coShowHints, + coShowInfos, + coShowLineNumbers, + coShowConditionals, + coShowUsedTools, + coShowMessageNumbers, // not in "show all" + coShowDebug, // not in "show all" + coAllowCAssignments, + coLowerCase, + coEnumValuesAsNumbers, + coKeepNotUsedPrivates, + coKeepNotUsedDeclarationsWPO, + coSourceMapCreate, + coSourceMapInclude + ); + TP2jsCompilerOptions = set of TP2jsCompilerOption; +const + DefaultP2jsCompilerOptions = [coShowErrors]; + coShowAll = [coShowErrors..coShowUsedTools]; + coO1Enable = [coEnumValuesAsNumbers]; + coO1Disable = [coKeepNotUsedPrivates,coKeepNotUsedDeclarationsWPO]; + + p2jscoCaption: array[TP2jsCompilerOption] of string = ( + // only used by experts, no need for resourcestrings + 'Skip default configs', + 'Build all', + 'Show logo', + 'Show errors', + 'Show warnings', + 'Show notes', + 'Show hints', + 'Show infos', + 'Show line numbers', + 'Show conditionals', + 'Show used tools', + 'Show message numbers', + 'Show debug', + 'Allow C assignments', + 'Lowercase identifiers', + 'Enum values as numbers', + 'Keep not used private declarations', + 'Keep not used declarations (WPO)', + 'Create source map', + 'Include Pascal sources in source map' + ); + +//------------------------------------------------------------------------------ +// $mode and $modeswitches +type + TP2jsMode = ( + p2jmObjFPC, + p2jmDelphi + ); + TP2jsModes = set of TP2jsMode; +const + p2jscModeNames: array[TP2jsMode] of string = ( + 'ObjFPC', + 'Delphi' + ); + p2jsMode_SwitchSets: array[TP2jsMode] of TModeSwitches = ( + OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly, + DelphiModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly + ); + +//------------------------------------------------------------------------------ +// param macros +type + EPas2jsMacro = class(Exception); + + TOnSubstituteMacro = function(Sender: TObject; var Params: string; Lvl: integer): boolean of object; + + { TPas2jsMacro } + + TPas2jsMacro = class + public + Name: string; + Description: string; + Value: string; + CanHaveParams: boolean; + OnSubstitute: TOnSubstituteMacro; + end; + + { TPas2jsMacroEngine } + + TPas2jsMacroEngine = class + private + fMacros: TObjectList; // list of TPas2jsMacro + FMaxLevel: integer; + function GetMacros(Index: integer): TPas2jsMacro; + public + constructor Create; + destructor Destroy; override; + function Count: integer; + function AddValue(const aName, aDescription, aValue: string): TPas2jsMacro; + function AddFunction(const aName, aDescription: string; + const OnSubstitute: TOnSubstituteMacro; CanHaveParams: boolean): TPas2jsMacro; + function IndexOf(const aName: string): integer; + procedure Delete(Index: integer); + function FindMacro(const aName: string): TPas2jsMacro; + procedure Substitute(var s: string; Sender: TObject = nil; Lvl: integer = 0); + property Macros[Index: integer]: TPas2jsMacro read GetMacros; default; + property MaxLevel: integer read FMaxLevel write FMaxLevel; + end; + +//------------------------------------------------------------------------------ +// Module file +type + ECompilerTerminate = class(Exception); + + TPas2jsCompiler = class; + + TUsedBySection = ( + ubMainSection, + ubImplSection + ); + + { TPas2jsCompilerFile } + + TPas2jsCompilerFile = class + private + FCompiler: TPas2jsCompiler; + FConverter: TPasToJSConverter; + FFileResolver: TPas2jsFileResolver; + FIsForeign: boolean; + FIsMainFile: boolean; + FJSFilename: string; + FJSModule: TJSElement; + FLog: TPas2jsLogger; + FNeedBuild: Boolean; + FParser: TPas2jsPasParser; + FPasFilename: String; + FPasModule: TPasModule; + FPasResolver: TPas2jsCompilerResolver; + FPasUnitName: string; + FScanner: TPascalScanner; + FShowDebug: boolean; + FUseAnalyzer: TPasAnalyzer; + FUsedBy: array[TUsedBySection] of TFPList; // list of TPas2jsCompilerFile + procedure FPasResolverContinueParsing(Sender: TObject); + function GetUsedBy(Section: TUsedBySection; Index: integer): TPas2jsCompilerFile; + function GetUsedByCount(Section: TUsedBySection): integer; + function OnConverterIsElementUsed(Sender: TObject; El: TPasElement): boolean; + function OnConverterIsTypeInfoUsed(Sender: TObject; El: TPasElement): boolean; + procedure OnPasResolverLog(Sender: TObject; const Msg: String); + procedure OnParserLog(Sender: TObject; const Msg: String); + procedure OnScannerLog(Sender: TObject; const Msg: String); + procedure OnUseAnalyzerMessage(Sender: TObject; Msg: TPAMessage); + procedure SetJSFilename(AValue: string); + procedure HandleEParserError(E: EParserError); + procedure HandleEPasResolve(E: EPasResolve); + procedure HandleEPas2JS(E: EPas2JS); + procedure HandleUnknownException(E: Exception); + procedure HandleException(E: Exception); + procedure DoLogMsgAtEl(MsgType: TMessageType; const Msg: string; + MsgNumber: integer; El: TPasElement); + procedure RaiseInternalError(id: int64; Msg: string); + procedure ParserFinished; + public + constructor Create(aCompiler: TPas2jsCompiler; const aPasFilename: string); + destructor Destroy; override; + procedure CreateScannerAndParser(aFileResolver: TPas2jsFileResolver); + function OnPasTreeFindModule(const UseUnitname: String): TPasModule; + function FindUnit(const UseUnitname: String): TPasModule; + procedure OnPasTreeCheckSrcName(const Element: TPasElement); + procedure OpenFile(aFilename: string);// beware: this changes FileResolver.BaseDirectory + procedure ParsePascal; + procedure CreateJS; + function GetPasFirstSection: TPasSection; + function GetPasImplSection: TPasSection; + function GetPasMainUsesClause: TPasUsesClause; + function GetPasImplUsesClause: TPasUsesClause; + function GetCurPasModule: TPasModule; + function GetModuleName: string; + class function GetFile(aModule: TPasModule): TPas2jsCompilerFile; + public + property Compiler: TPas2jsCompiler read FCompiler; + property Converter: TPasToJSConverter read FConverter; + property FileResolver: TPas2jsFileResolver read FFileResolver; + property IsForeign: boolean read FIsForeign write FIsForeign;// true = do not build + property IsMainFile: boolean read FIsMainFile write FIsMainFile; + property JSFilename: string read FJSFilename write SetJSFilename; + property JSModule: TJSElement read FJSModule; + property Log: TPas2jsLogger read FLog; + property NeedBuild: Boolean read FNeedBuild write FNeedBuild; + property Parser: TPas2jsPasParser read FParser; + property PascalResolver: TPas2jsCompilerResolver read FPasResolver; + property PasFilename: String read FPasFilename; + property PasModule: TPasModule read FPasModule; + property PasUnitName: string read FPasUnitName write FPasUnitName;// unit name in program + property Scanner: TPascalScanner read FScanner; + property ShowDebug: boolean read FShowDebug write FShowDebug; + property UseAnalyzer: TPasAnalyzer read FUseAnalyzer; // unit analysis + property UsedByCount[Section: TUsedBySection]: integer read GetUsedByCount; + property UsedBy[Section: TUsedBySection; Index: integer]: TPas2jsCompilerFile read GetUsedBy; + end; + + { TPas2JSWPOptimizer } + + TPas2JSWPOptimizer = class(TPasAnalyzer) + public + end; + + { TPas2jsCompiler } + + TPas2jsCompiler = class + private + FCompilerExe: string; + FConditionEval: TCondDirectiveEvaluator; + FCurrentCfgFilename: string; + FCurrentCfgLineNumber: integer; + FDefines: TStrings; // Objects can be TMacroDef + FFileCache: TPas2jsFilesCache; + FFileCacheAutoFree: boolean; + FFiles: TAVLTree; // tree of TPas2jsCompilerFile sorted for PasFilename + FHasShownLogo: boolean; + FLog: TPas2jsLogger; + FMainFile: TPas2jsCompilerFile; + FMode: TP2jsMode; + FOptions: TP2jsCompilerOptions; + FParamMacros: TPas2jsMacroEngine; + FSrcMapSourceRoot: string; + FTargetPlatform: TPasToJsPlatform; + FTargetProcessor: TPasToJsProcessor; + FUnits: TAVLTree; // tree of TPas2jsCompilerFile sorted for UnitName + FWPOAnalyzer: TPas2JSWPOptimizer; + function ConditionEvalVariable(Sender: TCondDirectiveEvaluator; + aName: String; out Value: string): boolean; + function GetDefaultNamespace: String; + function GetFileCount: integer; + function GetShowDebug: boolean; inline; + function GetShowFullPaths: boolean; + function GetShowLogo: Boolean; inline; + function GetShowTriedUsedFiles: boolean; inline; + function GetShowUsedTools: boolean; inline; + function GetSkipDefaultConfig: Boolean; inline; + function GetSrcMapBaseDir: string; + function GetSrcMapEnable: boolean; + function GetSrcMapInclude: boolean; + function OnMacroCfgDir(Sender: TObject; var Params: string; Lvl: integer + ): boolean; + function OnMacroEnv(Sender: TObject; var Params: string; Lvl: integer + ): boolean; + procedure AddDefinesForTargetPlatform; + procedure AddDefinesForTargetProcessor; + procedure CfgSyntaxError(const Msg: string); + procedure ConditionEvalLog(Sender: TCondDirectiveEvaluator; + Args: array of const); + procedure LoadConfig(CfgFilename: string); + procedure LoadDefaultConfig; + procedure ParamFatal(Msg: string); + procedure ReadParam(Param: string; Quick, FromCmdLine: boolean); + procedure ReadSingleLetterOptions(const Param: string; p: PChar; + const Allowed: string; out Enabled, Disabled: string); + procedure ReadSyntaxFlags(Param: String; p: PChar); + procedure ReadVerbosityFlags(Param: String; p: PChar); + procedure RegisterMessages; + procedure SetCompilerExe(AValue: string); + procedure SetFileCache(AValue: TPas2jsFilesCache); + procedure SetMode(AValue: TP2jsMode); + procedure SetOptions(AValue: TP2jsCompilerOptions); + procedure SetShowDebug(AValue: boolean); + procedure SetShowFullPaths(AValue: boolean); + procedure SetShowLogo(AValue: Boolean); + procedure SetShowTriedUsedFiles(AValue: boolean); + procedure SetShowUsedTools(AValue: boolean); + procedure SetSkipDefaultConfig(AValue: Boolean); + procedure SetSrcMapBaseDir(const AValue: string); + procedure SetSrcMapEnable(const AValue: boolean); + procedure SetSrcMapInclude(const AValue: boolean); + procedure SetTargetPlatform(const AValue: TPasToJsPlatform); + procedure SetTargetProcessor(const AValue: TPasToJsProcessor); + protected + // If this function returns true, the compiler assumes the file was written. + // If false, the compiler will attempt to write the file itself. + function DoWriteJSFile(const DestFilename: String; aWriter: TPas2JSMapper): Boolean; virtual; + procedure Compile(StartTime: TDateTime); + function MarkNeedBuilding(aFile: TPas2jsCompilerFile; Checked: TAVLTree; + var SrcFileCount: integer): boolean; + procedure OptimizeProgram(aFile: TPas2jsCompilerFile); virtual; + procedure CreateJavaScript(aFile: TPas2jsCompilerFile; Checked: TAVLTree); + procedure FinishSrcMap(SrcMap: TPas2JSSrcMap); virtual; + procedure WriteJSFiles(aFile: TPas2jsCompilerFile; + var CombinedFileWriter: TPas2JSMapper; Checked: TAVLTree); + procedure InitParamMacros; + procedure ClearDefines; + procedure RaiseInternalError(id: int64; Msg: string); + public + constructor Create; virtual; + destructor Destroy; override; + + procedure Reset; + procedure Run( + aCompilerExe: string; // needed for default config and help + aWorkingDir: string; + ParamList: TStrings; + DoReset: boolean = true); + procedure Terminate(TheExitCode: integer); + + class function GetVersion(ShortVersion: boolean): string; + procedure WriteHelp; + procedure WriteLogo; + procedure WriteOptions; + procedure WriteDefines; + procedure WriteFoldersAndSearchPaths; + function GetShownMsgTypes: TMessageTypes; + + procedure AddDefine(const aName: String); + procedure AddDefine(const aName, Value: String); + procedure RemoveDefine(const aName: String); + function IsDefined(const aName: String): boolean; + procedure SetOption(Flag: TP2jsCompilerOption; Enable: boolean); + + function FindPasFile(PasFilename: string): TPas2jsCompilerFile; + procedure LoadPasFile(PasFilename, UseUnitName: string; out aFile: TPas2jsCompilerFile); + function FindUsedUnit(const TheUnitName: string): TPas2jsCompilerFile; + procedure AddUsedUnit(aFile: TPas2jsCompilerFile); + public + property CompilerExe: string read FCompilerExe write SetCompilerExe; + property ConditionEvaluator: TCondDirectiveEvaluator read FConditionEval; + property CurrentCfgFilename: string read FCurrentCfgFilename; + property CurrentCfgLineNumber: integer read FCurrentCfgLineNumber; + property DefaultNamespace: String read GetDefaultNamespace; + property Defines: TStrings read FDefines; + property FileCache: TPas2jsFilesCache read FFileCache write SetFileCache; + property FileCacheAutoFree: boolean read FFileCacheAutoFree write FFileCacheAutoFree; + property FileCount: integer read GetFileCount; + property Log: TPas2jsLogger read FLog; + property MainFile: TPas2jsCompilerFile read FMainFile; + property Mode: TP2jsMode read FMode write SetMode; + property Options: TP2jsCompilerOptions read FOptions write SetOptions; + property ParamMacros: TPas2jsMacroEngine read FParamMacros; + property SrcMapEnable: boolean read GetSrcMapEnable write SetSrcMapEnable; + property SrcMapSourceRoot: string read FSrcMapSourceRoot write FSrcMapSourceRoot; + property SrcMapBaseDir: string read GetSrcMapBaseDir write SetSrcMapBaseDir; + property SrcMapInclude: boolean read GetSrcMapInclude write SetSrcMapInclude; + property ShowDebug: boolean read GetShowDebug write SetShowDebug; + property ShowFullPaths: boolean read GetShowFullPaths write SetShowFullPaths; + property ShowLogo: Boolean read GetShowLogo write SetShowLogo; + property ShowTriedUsedFiles: boolean read GetShowTriedUsedFiles write SetShowTriedUsedFiles; + property ShowUsedTools: boolean read GetShowUsedTools write SetShowUsedTools; + property SkipDefaultConfig: Boolean read GetSkipDefaultConfig write SetSkipDefaultConfig; + property TargetPlatform: TPasToJsPlatform read FTargetPlatform write SetTargetPlatform; + property TargetProcessor: TPasToJsProcessor read FTargetProcessor write SetTargetProcessor; + property WPOAnalyzer: TPas2JSWPOptimizer read FWPOAnalyzer; // Whole Program Optimization + end; + +function CompareCompilerFilesPasFile(Item1, Item2: Pointer): integer; +function CompareFileAndCompilerFilePasFile(Filename, Item: Pointer): integer; +function CompareCompilerFilesPasUnitname(Item1, Item2: Pointer): integer; +function CompareUnitnameAndCompilerFile(TheUnitname, Item: Pointer): integer; + +implementation + +function CompareCompilerFilesPasFile(Item1, Item2: Pointer): integer; +var + File1: TPas2jsCompilerFile absolute Item1; + File2: TPas2jsCompilerFile absolute Item2; +begin + Result:=CompareFilenames(File1.PasFilename,File2.PasFilename); +end; + +function CompareFileAndCompilerFilePasFile(Filename, Item: Pointer): integer; +var + aFile: TPas2jsCompilerFile absolute Item; + aFilename: String; +begin + aFilename:=AnsiString(Filename); + Result:=CompareFilenames(aFilename,aFile.PasFilename); +end; + +function CompareCompilerFilesPasUnitname(Item1, Item2: Pointer): integer; +var + File1: TPas2jsCompilerFile absolute Item1; + File2: TPas2jsCompilerFile absolute Item2; +begin + Result:=CompareText(File1.PasUnitName,File2.PasUnitName); +end; + +function CompareUnitnameAndCompilerFile(TheUnitname, Item: Pointer): integer; +var + aFile: TPas2jsCompilerFile absolute Item; + anUnitname: String; +begin + anUnitname:=AnsiString(TheUnitname); + Result:=CompareText(anUnitname,aFile.PasUnitName); +end; + +{ TPas2jsMacroEngine } + +function TPas2jsMacroEngine.GetMacros(Index: integer): TPas2jsMacro; +begin + Result:=TPas2jsMacro(fMacros[Index]); +end; + +constructor TPas2jsMacroEngine.Create; +begin + fMacros:=TObjectList.Create(true); + FMaxLevel:=10; +end; + +destructor TPas2jsMacroEngine.Destroy; +begin + FreeAndNil(fMacros); + inherited Destroy; +end; + +function TPas2jsMacroEngine.Count: integer; +begin + Result:=fMacros.Count; +end; + +function TPas2jsMacroEngine.AddValue(const aName, aDescription, aValue: string + ): TPas2jsMacro; +begin + if not IsValidIdent(aName) then + raise EPas2jsMacro.Create('invalid macro name "'+aName+'"'); + if IndexOf(aName)>=0 then + raise EPas2jsMacro.Create('duplicate macro name "'+aName+'"'); + Result:=TPas2jsMacro.Create; + Result.Name:=aName; + Result.Description:=aDescription; + Result.Value:=aValue; + fMacros.Add(Result); +end; + +function TPas2jsMacroEngine.AddFunction(const aName, aDescription: string; + const OnSubstitute: TOnSubstituteMacro; CanHaveParams: boolean): TPas2jsMacro; +begin + if not IsValidIdent(aName) then + raise EPas2jsMacro.Create('invalid macro name "'+aName+'"'); + if IndexOf(aName)>=0 then + raise EPas2jsMacro.Create('duplicate macro name "'+aName+'"'); + Result:=TPas2jsMacro.Create; + Result.Name:=aName; + Result.Description:=aDescription; + Result.CanHaveParams:=CanHaveParams; + Result.OnSubstitute:=OnSubstitute; + fMacros.Add(Result); +end; + +function TPas2jsMacroEngine.IndexOf(const aName: string): integer; +var + i: Integer; +begin + for i:=0 to Count-1 do + if CompareText(Macros[i].Name,aName)=0 then + exit(i); + Result:=-1; +end; + +procedure TPas2jsMacroEngine.Delete(Index: integer); +begin + fMacros.Delete(Index); +end; + +function TPas2jsMacroEngine.FindMacro(const aName: string): TPas2jsMacro; +var + i: Integer; +begin + i:=IndexOf(aName); + if i>=0 then + Result:=Macros[i] + else + Result:=nil; +end; + +procedure TPas2jsMacroEngine.Substitute(var s: string; Sender: TObject; + Lvl: integer); +// Rules: +// $macro or $macro$ +// if Macro.OnSubstitute is set then optional brackets are allowed: $macro(params) +var + p, StartP, BracketLvl, ParamStartP: Integer; + MacroName, NewValue: String; + Macro: TPas2jsMacro; +begin + if Lvl>=MaxLevel then + raise EPas2jsMacro.Create('macro cycle detected: "'+s+'"'); + p:=1; + while p<length(s) do begin + if (s[p]='$') and (s[p+1] in ['_','a'..'z','A'..'Z']) then begin + StartP:=p; + inc(p,2); + while (p<=length(s)) and (s[p] in ['_','a'..'z','A'..'Z','0'..'9']) do + inc(p); + MacroName:=copy(s,StartP+1,p-StartP-1); + Macro:=FindMacro(MacroName); + if Macro=nil then + raise EPas2jsMacro.Create('macro not found "'+MacroName+'" in "'+s+'"'); + NewValue:=''; + if Macro.CanHaveParams and (p<=length(s)) and (s[p]='(') then begin + // read NewValue + inc(p); + ParamStartP:=p; + BracketLvl:=1; + repeat + if p>length(s) then + raise EPas2jsMacro.Create('missing closing bracket ) in "'+s+'"'); + case s[p] of + '(': inc(BracketLvl); + ')': + if BracketLvl=1 then begin + NewValue:=copy(s,ParamStartP,p-ParamStartP); + break; + end else begin + dec(BracketLvl); + end; + end; + until false; + end else if (p<=length(s)) and (s[p]='$') then + inc(p); + if Assigned(Macro.OnSubstitute) then begin + if not Macro.OnSubstitute(Sender,NewValue,Lvl+1) then + raise EPas2jsMacro.Create('macro "'+MacroName+'" failed in "'+s+'"'); + end else + NewValue:=Macro.Value; + s:=LeftStr(s,StartP-1)+NewValue+copy(s,p,length(s)); + p:=StartP; + end; + inc(p); + end; +end; + +{ TPas2jsCompilerFile } + +constructor TPas2jsCompilerFile.Create(aCompiler: TPas2jsCompiler; + const aPasFilename: string); +var + ub: TUsedBySection; +begin + FCompiler:=aCompiler; + FLog:=Compiler.Log; + FPasFilename:=aPasFilename; + FPasResolver:=TPas2jsCompilerResolver.Create; + FPasResolver.Owner:=Self; + FPasResolver.OnContinueParsing:=@FPasResolverContinueParsing; + FPasResolver.OnFindModule:=@OnPasTreeFindModule; + FPasResolver.OnCheckSrcName:=@OnPasTreeCheckSrcName; + FPasResolver.OnLog:=@OnPasResolverLog; + FPasResolver.Log:=Log; + FPasResolver.AddObjFPCBuiltInIdentifiers(btAllJSBaseTypes,bfAllJSBaseProcs); + FIsMainFile:=CompareFilenames(aCompiler.FileCache.MainSrcFile,aPasFilename)=0; + for ub in TUsedBySection do + FUsedBy[ub]:=TFPList.Create; + FUseAnalyzer:=TPasAnalyzer.Create; + FUseAnalyzer.OnMessage:=@OnUseAnalyzerMessage; + FUseAnalyzer.Resolver:=FPasResolver; +end; + +destructor TPas2jsCompilerFile.Destroy; +var + ub: TUsedBySection; +begin + FreeAndNil(FUseAnalyzer); + for ub in TUsedBySection do + FreeAndNil(FUsedBy[ub]); + FreeAndNil(FJSModule); + FreeAndNil(FConverter); + if FPasModule<>nil then begin + FPasModule.Release; + FPasModule:=nil; + end; + FreeAndNil(FParser); + FreeAndNil(FScanner); + FreeAndNil(FFileResolver); + FreeAndNil(FPasResolver); + inherited Destroy; +end; + +procedure TPas2jsCompilerFile.CreateScannerAndParser(aFileResolver: TPas2jsFileResolver); +var + aUnitName: String; + i: Integer; + M: TMacroDef; +begin + FFileResolver:=aFileResolver; + // scanner + FScanner := TPascalScanner.Create(FileResolver); + Scanner.LogEvents:=PascalResolver.ScannerLogEvents; + Scanner.OnLog:=@OnScannerLog; + Scanner.OnFormatPath:=@Compiler.FileCache.FormatPath; + + // create parser (Note: this sets some scanner options to defaults) + FParser := TPas2jsPasParser.Create(Scanner, FileResolver, PascalResolver); + + // set options + Scanner.AllowedModeSwitches:=msAllPas2jsModeSwitches; + Scanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly; + Scanner.CurrentModeSwitches:=p2jsMode_SwitchSets[Compiler.Mode]; + // Note: some Scanner.Options are set by TPasResolver + for i:=0 to Compiler.Defines.Count-1 do + begin + M:=TMacroDef(Compiler.Defines.Objects[i]); + if M=nil then + Scanner.AddDefine(Compiler.Defines[i]) + else + Scanner.AddMacro(M.Name,M.Value); + end; + if coAllowCAssignments in Compiler.Options then + Scanner.Options:=Scanner.Options+[po_cassignments]; + if Compiler.Mode=p2jmDelphi then + Scanner.Options:=Scanner.Options+[po_delphi]; + + // parser + Parser.LogEvents:=PascalResolver.ParserLogEvents; + Parser.OnLog:=@OnParserLog; + Parser.Log:=Log; + PascalResolver.P2JParser:=Parser; + + if not IsMainFile then begin + aUnitName:=ExtractFilenameOnly(PasFilename); + if CompareText(aUnitName,'system')=0 then + Parser.ImplicitUses.Clear; + end; +end; + +procedure TPas2jsCompilerFile.OnPasTreeCheckSrcName(const Element: TPasElement); +var + SrcName, ExpectedSrcName: String; +begin + //writeln('TPas2jsCompilerFile.OnPasTreeCheckSrcName ',PasFilename,' Name=',Element.Name,' IsMainFile=',IsMainFile); + if (Element.ClassType=TPasUnitModule) or (Element.ClassType=TPasModule) then + begin + SrcName:=Element.Name; + if IsMainFile then begin + // main source is an unit + if PasUnitName='' then begin + {$IFDEF VerboseSetPasUnitName} + writeln('TPas2jsCompilerFile.OnPasTreeCheckSrcName ',PasFilename,' Name=',Element.Name,' IsMainFile=',IsMainFile); + {$ENDIF} + PasUnitName:=SrcName; + Compiler.AddUsedUnit(Self); + end; + end else begin + // an unit name must fit its filename + ExpectedSrcName:=ExtractFilenameOnly(PasFilename); + if CompareText(SrcName,ExpectedSrcName)=0 then + exit; // ok + Parser.RaiseParserError(nExpectedButFound,[ExpectedSrcName,SrcName]); + end; + end; +end; + +function TPas2jsCompilerFile.GetUsedBy(Section: TUsedBySection; Index: integer + ): TPas2jsCompilerFile; +begin + Result:=TPas2jsCompilerFile(FUsedBy[Section][Index]); +end; + +procedure TPas2jsCompilerFile.FPasResolverContinueParsing(Sender: TObject); +begin + try + Parser.ParseContinueImplementation; + except + on E: Exception do + HandleException(E); + end; + ParserFinished; +end; + +function TPas2jsCompilerFile.GetUsedByCount(Section: TUsedBySection): integer; +begin + Result:=FUsedBy[Section].Count; +end; + +function TPas2jsCompilerFile.OnConverterIsElementUsed(Sender: TObject; + El: TPasElement): boolean; +begin + if (Compiler.WPOAnalyzer<>nil) + and not (coKeepNotUsedDeclarationsWPO in Compiler.Options) then + Result:=Compiler.WPOAnalyzer.IsUsed(El) + else if not (coKeepNotUsedPrivates in Compiler.Options) then + Result:=UseAnalyzer.IsUsed(El) + else + Result:=true; +end; + +function TPas2jsCompilerFile.OnConverterIsTypeInfoUsed(Sender: TObject; + El: TPasElement): boolean; +begin + if (Compiler.WPOAnalyzer<>nil) + and not (coKeepNotUsedDeclarationsWPO in Compiler.Options) then + Result:=Compiler.WPOAnalyzer.IsTypeInfoUsed(El) + else if not (coKeepNotUsedPrivates in Compiler.Options) then + Result:=UseAnalyzer.IsTypeInfoUsed(El) + else + Result:=true; +end; + +procedure TPas2jsCompilerFile.OnPasResolverLog(Sender: TObject; const Msg: String); +var + aResolver: TPasResolver; +begin + if Msg='' then ; // ignore standard formatted message + aResolver:=TPasResolver(Sender); + DoLogMsgAtEl(aResolver.LastMsgType,aResolver.LastMsg,aResolver.LastMsgNumber, + aResolver.LastElement); +end; + +procedure TPas2jsCompilerFile.OnParserLog(Sender: TObject; const Msg: String); +var + aParser: TPasParser; + aScanner: TPascalScanner; +begin + if Msg='' then ; // ignore standard formatted message + aParser:=TPasParser(Sender); + aScanner:=aParser.Scanner; + Log.Log(aParser.LastMsgType,aParser.LastMsg,aParser.LastMsgNumber, + aScanner.CurFilename,aScanner.CurRow,aScanner.CurColumn); +end; + +procedure TPas2jsCompilerFile.OnScannerLog(Sender: TObject; const Msg: String); +var + aScanner: TPascalScanner; +begin + if Msg='' then ; // ignore standard formatted message + aScanner:=TPascalScanner(Sender); + Log.Log(aScanner.LastMsgType,aScanner.LastMsg,aScanner.LastMsgNumber, + aScanner.CurFilename,aScanner.CurRow,aScanner.CurColumn); +end; + +procedure TPas2jsCompilerFile.OnUseAnalyzerMessage(Sender: TObject; + Msg: TPAMessage); +begin + Log.Log(Msg.MsgType,Msg.MsgText,Msg.MsgNumber,Msg.Filename,Msg.Row,Msg.Col); +end; + +procedure TPas2jsCompilerFile.SetJSFilename(AValue: string); +begin + if FJSFilename=AValue then Exit; + FJSFilename:=AValue; +end; + +procedure TPas2jsCompilerFile.HandleEParserError(E: EParserError); +begin + Log.Log(Parser.LastMsgType,Parser.LastMsg,Parser.LastMsgNumber, + E.Filename,E.Row,E.Column); + Compiler.Terminate(ExitCodeSyntaxError); +end; + +procedure TPas2jsCompilerFile.HandleEPasResolve(E: EPasResolve); +var + aFilename: String; + aRow, aColumn: integer; +begin + if E.PasElement<>nil then begin + aFilename:=E.PasElement.SourceFilename; + PascalResolver.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aColumn); + end else begin + aFilename:=Scanner.CurFilename; + aRow:=Scanner.CurRow; + aColumn:=Scanner.CurColumn; + end; + Log.Log(E.MsgType,E.Message,E.MsgNumber,aFilename,aRow,aColumn); + Compiler.Terminate(ExitCodeSyntaxError); +end; + +procedure TPas2jsCompilerFile.HandleEPas2JS(E: EPas2JS); +var + aFilename: String; + aRow, aColumn: integer; +begin + if E.PasElement<>nil then begin + aFilename:=E.PasElement.SourceFilename; + PascalResolver.UnmangleSourceLineNumber(E.PasElement.SourceLinenumber,aRow,aColumn); + Log.Log(E.MsgType,E.Message,E.MsgNumber,aFilename,aRow,aColumn); + end else begin + Log.Log(E.MsgType,E.Message,E.MsgNumber); + end; + Compiler.Terminate(ExitCodeConverterError); +end; + +procedure TPas2jsCompilerFile.HandleUnknownException(E: Exception); +begin + if not (E is ECompilerTerminate) then + Log.Log(mtFatal,E.ClassName+': '+E.Message,0); + Compiler.Terminate(ExitCodeErrorInternal); +end; + +procedure TPas2jsCompilerFile.HandleException(E: Exception); +begin + if E is EScannerError then begin + Log.Log(Scanner.LastMsgType,Scanner.LastMsg,Scanner.LastMsgNumber, + Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn); + Compiler.Terminate(ExitCodeSyntaxError); + end else if E is EParserError then + HandleEParserError(EParserError(E)) + else if E is EPasResolve then + HandleEPasResolve(EPasResolve(E)) + else if E is EPas2JS then + HandleEPas2JS(EPas2JS(E)) + else + HandleUnknownException(E); +end; + +procedure TPas2jsCompilerFile.DoLogMsgAtEl(MsgType: TMessageType; + const Msg: string; MsgNumber: integer; El: TPasElement); +var + Line, Col: integer; + Filename: String; +begin + if (El<>nil) then begin + Filename:=El.SourceFilename; + TPasResolver.UnmangleSourceLineNumber(El.SourceLinenumber,Line,Col); + end else begin + Filename:=''; + Line:=0; + Col:=0; + end; + Log.Log(MsgType,Msg,MsgNumber,Filename,Line,Col); +end; + +procedure TPas2jsCompilerFile.RaiseInternalError(id: int64; Msg: string); +begin + Compiler.RaiseInternalError(id,Msg); +end; + +procedure TPas2jsCompilerFile.ParserFinished; +begin + try + if ShowDebug then begin + Log.LogRaw('Pas-Module:'); + Log.LogRaw(PasModule.GetDeclaration(true)); + end; + if PasModule.CustomData=nil then + PasModule.CustomData:=Self; + + // analyze + UseAnalyzer.AnalyzeModule(FPasModule); + except + on E: Exception do + HandleException(E); + end; +end; + +procedure TPas2jsCompilerFile.OpenFile(aFilename: string); +begin + FPasFilename:=aFilename; + try + Scanner.OpenFile(PasFilename); + except + on E: EScannerError do begin + Log.Log(Scanner.LastMsgType,Scanner.LastMsg,Scanner.LastMsgNumber, + Scanner.CurFilename,Scanner.CurRow,Scanner.CurColumn); + Compiler.Terminate(ExitCodeSyntaxError); + end; + end; +end; + +procedure TPas2jsCompilerFile.ParsePascal; +begin + if ShowDebug then + Log.LogRaw(['Debug: Parsing Pascal "',PasFilename,'"...']); + try + // parse Pascal + PascalResolver.InterfaceOnly:=IsForeign; + if IsMainFile then + Parser.ParseMain(FPasModule) + else + Parser.ParseSubModule(FPasModule); + except + on E: Exception do + HandleException(E); + end; + if (FPasModule.ImplementationSection<>nil) + and (FPasModule.ImplementationSection.PendingUsedIntf<>nil) then + exit; + ParserFinished; +end; + +procedure TPas2jsCompilerFile.CreateJS; +begin + try + // show hints only for units that are actually converted + UseAnalyzer.EmitModuleHints(PasModule); + + // convert + FConverter:=TPasToJSConverter.Create; + FConverter.Options:=FConverter.Options+[coUseStrict]; + if coEnumValuesAsNumbers in Compiler.Options then + FConverter.Options:=FConverter.Options+[fppas2js.coEnumNumbers]; + FConverter.UseLowerCase:=coLowerCase in Compiler.Options; + FConverter.TargetPlatform:=Compiler.TargetPlatform; + FConverter.TargetProcessor:=Compiler.TargetProcessor; + FConverter.OnIsElementUsed:=@OnConverterIsElementUsed; + FConverter.OnIsTypeInfoUsed:=@OnConverterIsTypeInfoUsed; + FJSModule:=Converter.ConvertPasElement(PasModule,PascalResolver); + except + on E: Exception do + HandleException(E); + end; +end; + +function TPas2jsCompilerFile.GetPasFirstSection: TPasSection; +var + aModule: TPasModule; +begin + aModule:=GetCurPasModule; + if aModule=nil then exit; + if aModule.ClassType=TPasUnitModule then + Result:=TPasUnitModule(aModule).InterfaceSection + else if aModule.ClassType=TPasProgram then + Result:=TPasProgram(aModule).ProgramSection + else if aModule.ClassType=TPasLibrary then + Result:=TPasLibrary(aModule).LibrarySection + else + Result:=nil; +end; + +function TPas2jsCompilerFile.GetPasImplSection: TPasSection; +var + aModule: TPasModule; +begin + Result:=nil; + aModule:=GetCurPasModule; + if aModule=nil then exit; + Result:=aModule.ImplementationSection; +end; + +function TPas2jsCompilerFile.GetPasMainUsesClause: TPasUsesClause; +var + aModule: TPasModule; + IntfSection: TInterfaceSection; + PrgSection: TProgramSection; + LibSection: TLibrarySection; +begin + Result:=nil; + aModule:=GetCurPasModule; + if aModule=nil then exit; + if aModule.ClassType=TPasModule then begin + IntfSection:=TPasModule(aModule).InterfaceSection; + if IntfSection<>nil then + Result:=IntfSection.UsesClause; + end else if aModule.ClassType=TPasProgram then begin + PrgSection:=TPasProgram(aModule).ProgramSection; + if PrgSection<>nil then + Result:=PrgSection.UsesClause; + end else if aModule.ClassType=TPasLibrary then begin + LibSection:=TPasLibrary(aModule).LibrarySection; + if LibSection<>nil then + Result:=LibSection.UsesClause; + end; +end; + +function TPas2jsCompilerFile.GetPasImplUsesClause: TPasUsesClause; +var + aModule: TPasModule; +begin + Result:=nil; + aModule:=GetCurPasModule; + if aModule=nil then exit; + if aModule.ImplementationSection<>nil then + Result:=aModule.ImplementationSection.UsesClause; +end; + +function TPas2jsCompilerFile.GetCurPasModule: TPasModule; +begin + if PasModule<>nil then + Result:=PasModule + else if Parser<>nil then + Result:=Parser.CurModule + else + Result:=nil; +end; + +function TPas2jsCompilerFile.GetModuleName: string; +var + aModule: TPasModule; +begin + aModule:=GetCurPasModule; + if aModule<>nil then + Result:=aModule.Name + else + Result:=''; + if Result='' then + Result:=ExtractFilenameOnly(PasFilename); +end; + +class function TPas2jsCompilerFile.GetFile(aModule: TPasModule + ): TPas2jsCompilerFile; +var + Scope: TPasModuleScope; + Resolver: TPas2jsCompilerResolver; +begin + Result:=nil; + if (aModule=nil) or (aModule.CustomData=nil) then exit; + if aModule.CustomData is TPas2jsCompilerFile then + Result:=TPas2jsCompilerFile(aModule.CustomData) + else if aModule.CustomData is TPasModuleScope then begin + Scope:=TPasModuleScope(aModule.CustomData); + Resolver:=NoNil(Scope.Owner) as TPas2jsCompilerResolver; + Result:=Resolver.Owner as TPas2jsCompilerFile; + end; +end; + +function TPas2jsCompilerFile.OnPasTreeFindModule(const UseUnitname: String): TPasModule; +var + aNameSpace: String; + LastEl: TPasElement; + i: Integer; +begin + Result:=nil; + if CompareText(ExtractFilenameOnly(PasFilename),UseUnitname)=0 then begin + // duplicate identifier or unit cycle + Parser.RaiseParserError(nUnitCycle,[UseUnitname]); + end; + + LastEl:=PascalResolver.LastElement; + if (LastEl<>nil) + and ((LastEl is TPasSection) or (LastEl.ClassType=TPasUsesUnit) + or (LastEl.Parent is TPasSection)) then + // ok + else + RaiseInternalError(20170504161408,'internal error TPas2jsCompilerFile.FindModule PasTree.LastElement='+GetObjName(LastEl)+' '+GetObjName(LastEl.Parent)); + + if (Pos('.',UseUnitname)<1) then begin + // generic unit -> search with namespaces + // first the default program namespace + aNameSpace:=Compiler.GetDefaultNamespace; + if aNameSpace<>'' then begin + Result:=FindUnit(aNameSpace+'.'+UseUnitname); + if Result<>nil then exit; + end; + + // then the cmdline namespaces + for i:=0 to Compiler.FileCache.Namespaces.Count-1 do begin + aNameSpace:=Compiler.FileCache.Namespaces[i]; + if aNameSpace='' then continue; + Result:=FindUnit(aNameSpace+'.'+UseUnitname); + if Result<>nil then exit; + end + end; + + // search in unitpath + Result:=FindUnit(UseUnitname); + // if nil resolver will give a nice error position +end; + +function TPas2jsCompilerFile.FindUnit(const UseUnitname: String): TPasModule; + + function FindCycle(aFile, SearchFor: TPas2jsCompilerFile; + var Cycle: TFPList): boolean; + var + i: Integer; + aParent: TPas2jsCompilerFile; + begin + for i:=0 to aFile.UsedByCount[ubMainSection]-1 do begin + aParent:=aFile.UsedBy[ubMainSection,i]; + if aParent=SearchFor then begin + // unit cycle found + Cycle:=TFPList.Create; + Cycle.Add(aParent); + Cycle.Add(aFile); + exit(true); + end; + if FindCycle(aParent,SearchFor,Cycle) then begin + Cycle.Add(aFile); + exit(true); + end; + end; + Result:=false; + end; + +var + aFile: TPas2jsCompilerFile; + + procedure CheckCycle; + var + i: Integer; + Cycle: TFPList; + CyclePath: String; + begin + if Parser.CurModule.ImplementationSection=nil then begin + // main uses section (e.g. interface or program, not implementation) + // -> check for cycles + + aFile.FUsedBy[ubMainSection].Add(Self); + + Cycle:=nil; + try + if FindCycle(aFile,aFile,Cycle) then begin + CyclePath:=''; + for i:=0 to Cycle.Count-1 do begin + if i>0 then CyclePath+=','; + CyclePath+=TPas2jsCompilerFile(Cycle[i]).GetModuleName; + end; + Parser.RaiseParserError(nUnitCycle,[CyclePath]); + end; + finally + Cycle.Free; + end; + end else begin + // implementation uses section + aFile.FUsedBy[ubImplSection].Add(Self); + end; + end; + +var + UsePasFilename, InFilename, UseJSFilename: String; + UseIsForeign: boolean; +begin + Result:=nil; + InFilename:=''; + + // first try registered units + aFile:=Compiler.FindUsedUnit(UseUnitname); + if aFile<>nil then begin + // known unit + if (aFile.PasUnitName<>'') and (CompareText(aFile.PasUnitName,UseUnitname)<>0) then + begin + Log.LogRaw(['Debug: TPas2jsPasTree.FindUnit unitname MISMATCH aFile.PasUnitname="',aFile.PasUnitName,'"', + ' Self=',FileResolver.Cache.FormatPath(PasFilename), + ' Uses=',UseUnitname, + ' IsForeign=',IsForeign]); + RaiseInternalError(20170504161412,'TPas2jsPasTree.FindUnit unit name mismatch'); + end; + CheckCycle; + end else begin + // new unit -> search + + // search Pascal file + UsePasFilename:=FileResolver.FindUnitFileName(UseUnitname,InFilename,UseIsForeign); + if UsePasFilename='' then begin + // can't find unit + exit; + end; + + UseJSFilename:=''; + if (not IsForeign) then + UseJSFilename:=FileResolver.FindUnitJSFileName(UsePasFilename); + // Log.LogRaw(['Debug: TPas2jsPasTree.FindUnit Self=',FileResolver.Cache.FormatPath(PasFilename), + // ' Uses=',UseUnitname,' Found="',FileResolver.Cache.FormatPath(UsePasFilename),'"', + // ' IsForeign=',IsForeign,' JSFile="',FileResolver.Cache.FormatPath(useJSFilename),'"']); + + // load Pascal file + Compiler.LoadPasFile(UsePasFilename,UseUnitname,aFile); + if aFile=Self then begin + // unit uses itself -> cycle + Parser.RaiseParserError(nUnitCycle,[UseUnitname]); + end; + if aFile.PasUnitName<>UseUnitname then + RaiseInternalError(20170922143329,'aFile.PasUnitName='+aFile.PasUnitName+' UseUnitname='+UseUnitname); + + Compiler.AddUsedUnit(aFile); + if aFile<>Compiler.FindUsedUnit(UseUnitname) then + begin + if Compiler.FindUsedUnit(UseUnitname)=nil then + RaiseInternalError(20170922143405,'UseUnitname='+UseUnitname) + else + RaiseInternalError(20170922143511,'UseUnitname='+UseUnitname+' Found='+Compiler.FindUsedUnit(UseUnitname).PasUnitName); + end; + CheckCycle; + + aFile.JSFilename:=UseJSFilename; + aFile.IsForeign:=UseIsForeign; + + // parse Pascal + aFile.ParsePascal; + // beware: the parser may not yet have finished due to unit cycles + end; + + Result:=aFile.PasModule; +end; + +{ TPas2jsCompiler } + +procedure TPas2jsCompiler.SetFileCache(AValue: TPas2jsFilesCache); +begin + if FFileCache=AValue then Exit; + FFileCacheAutoFree:=false; + FFileCache:=AValue; +end; + +procedure TPas2jsCompiler.CfgSyntaxError(const Msg: string); +begin + Log.Log(mtError,Msg,0,CurrentCfgFilename,CurrentCfgLineNumber,0); + Terminate(ExitCodeErrorInConfig); +end; + +function TPas2jsCompiler.GetFileCount: integer; +begin + Result:=FFiles.Count; +end; + +function TPas2jsCompiler.GetDefaultNamespace: String; +var + C: TClass; +begin + Result:=''; + if FMainFile=nil then exit; + if FMainFile.PasModule=nil then exit; + C:=FMainFile.PasModule.ClassType; + if (C=TPasProgram) or (C=TPasLibrary) or (C=TPasPackage) then + Result:=FMainFile.PascalResolver.DefaultNameSpace; +end; + +procedure TPas2jsCompiler.AddDefinesForTargetProcessor; +begin + AddDefine(PasToJsProcessorNames[TargetProcessor]); + case TargetProcessor of + ProcessorECMAScript5: AddDefine('ECMAScript', '5'); + ProcessorECMAScript6: AddDefine('ECMAScript', '6'); + end; +end; + +procedure TPas2jsCompiler.ConditionEvalLog(Sender: TCondDirectiveEvaluator; + Args: array of const); +begin + CfgSyntaxError(SafeFormat(Sender.MsgPattern,Args)); +end; + +function TPas2jsCompiler.ConditionEvalVariable(Sender: TCondDirectiveEvaluator; + aName: String; out Value: string): boolean; +var + i: Integer; + M: TMacroDef; + ms: TModeSwitch; +begin + // check defines + i:=FDefines.IndexOf(aName); + if i>=0 then begin + M:=TMacroDef(FDefines.Objects[i]); + if M=nil then + Value:=CondDirectiveBool[true] + else + Value:=M.Value; + exit(true); + end; + + // check modeswitches + ms:=StrToModeSwitch(aName); + if (ms<>msNone) and (ms in p2jsMode_SwitchSets[Mode]) then begin + Value:=CondDirectiveBool[true]; + exit(true); + end; +end; + +procedure TPas2jsCompiler.AddDefinesForTargetPlatform; +begin + AddDefine(PasToJsPlatformNames[TargetPlatform]); +end; + +procedure TPas2jsCompiler.Compile(StartTime: TDateTime); +var + Checked: TAVLTree; + CombinedFileWriter: TPas2JSMapper; + SrcFileCount: integer; + Seconds: TDateTime; +begin + if FMainFile<>nil then + RaiseInternalError(20170504192137,''); + Checked:=nil; + CombinedFileWriter:=nil; + SrcFileCount:=0; + try + // load main Pascal file + LoadPasFile(FileCache.MainSrcFile,'',FMainFile); + if MainFile=nil then exit; + // parse and load Pascal files recursively + FMainFile.ParsePascal; + + // whole program optimization + if MainFile.PasModule is TPasProgram then + OptimizeProgram(MainFile); + + // check what files need building + Checked:=TAVLTree.Create; + MarkNeedBuilding(MainFile,Checked,SrcFileCount); + FreeAndNil(Checked); + + // convert all Pascal to JavaScript + Checked:=TAVLTree.Create; + CreateJavaScript(MainFile,Checked); + FreeAndNil(Checked); + + // write .js files + Checked:=TAVLTree.Create; + WriteJSFiles(MainFile,CombinedFileWriter,Checked); + FreeAndNil(Checked); + + // write success message + if ExitCode=0 then begin + Seconds:=(Now-StartTime)*86400; + Log.LogMsgIgnoreFilter(nLinesInFilesCompiled, + [IntToStr(FileCache.ReadLineCounter),IntToStr(SrcFileCount), + FormatFloat('0.0',Seconds)]); + end; + finally + Checked.Free; + if ExitCode<>0 then + Log.LogMsgIgnoreFilter(nCompilationAborted,[]); + CombinedFileWriter.Free; + end; +end; + +function TPas2jsCompiler.MarkNeedBuilding(aFile: TPas2jsCompilerFile; + Checked: TAVLTree; var SrcFileCount: integer): boolean; + + procedure Mark(MsgNumber: integer; Args: array of const); + begin + if aFile.NeedBuild then exit; + aFile.NeedBuild:=true; + inc(SrcFileCount); + if ShowDebug or ShowTriedUsedFiles then + Log.LogMsg(MsgNumber,Args,'',0,0,false); + end; + + procedure CheckUsesClause(UsesClause: TPasUsesClause); + var + i: Integer; + UsedFile: TPas2jsCompilerFile; + aModule: TPasModule; + begin + if length(UsesClause)=0 then exit; + for i:=0 to length(UsesClause)-1 do begin + aModule:=UsesClause[i].Module as TPasModule; + UsedFile:=TPas2jsCompilerFile.GetFile(aModule); + if UsedFile=nil then + RaiseInternalError(20171214121631,aModule.Name); + if MarkNeedBuilding(UsedFile,Checked,SrcFileCount) then begin + if not aFile.NeedBuild then + Mark(nUnitNeedsCompileDueToUsedUnit, + [aFile.GetModuleName,UsedFile.GetModuleName]); + end; + end; + end; + +begin + Result:=false; + // check each file only once + if Checked.Find(aFile)<>nil then + exit(aFile.NeedBuild); + Checked.Add(aFile); + + if FileCache.AllJSIntoMainJS and (WPOAnalyzer<>nil) + and not WPOAnalyzer.IsUsed(aFile.PasModule) then + exit(false); + + // check dependencies + CheckUsesClause(aFile.GetPasMainUsesClause); + CheckUsesClause(aFile.GetPasImplUsesClause); + + if (not aFile.NeedBuild) and (not aFile.IsForeign) then begin + // this unit can be compiled + if aFile.IsMainFile then + Mark(nUnitNeedsCompileDueToOption,[aFile.GetModuleName,'<main source file>']) + else if coBuildAll in Options then + Mark(nUnitNeedsCompileDueToOption,[aFile.GetModuleName,'-B']) + else if FileCache.AllJSIntoMainJS then + Mark(nUnitNeedsCompileDueToOption,[aFile.GetModuleName,'-Jc']) + else if (aFile.JSFilename<>'') and (not FileExists(aFile.JSFilename)) then + Mark(nUnitNeedsCompileJSMissing,[aFile.GetModuleName,FileCache.FormatPath(aFile.JSFilename)]) + else if (aFile.JSFilename<>'') + and (FileAge(aFile.PasFilename)>FileAge(aFile.JSFilename)) then begin + // ToDo: replace FileAge with checksum + Mark(nUnitNeedsCompilePasHasChanged,[aFile.GetModuleName,FileCache.FormatPath(aFile.JSFilename)]) + end; + end; + + if aFile.NeedBuild then begin + // unit needs compile + if aFile.IsForeign then begin + // ... but is forbidden to compile + Log.LogMsg(nOptionForbidsCompile,[aFile.GetModuleName]); + Terminate(ExitCodeWriteError); + end; + end; + + Result:=aFile.NeedBuild; +end; + +procedure TPas2jsCompiler.OptimizeProgram(aFile: TPas2jsCompilerFile); +begin + if not FileCache.AllJSIntoMainJS then exit; + if coKeepNotUsedDeclarationsWPO in Options then exit; + if not (aFile.PasModule is TPasProgram) then exit; + FWPOAnalyzer:=TPas2JSWPOptimizer.Create; + FWPOAnalyzer.Resolver:=aFile.PascalResolver; + FWPOAnalyzer.Options:=FWPOAnalyzer.Options+[paoOnlyExports]; + FWPOAnalyzer.AnalyzeWholeProgram(TPasProgram(aFile.PasModule)); +end; + +procedure TPas2jsCompiler.CreateJavaScript(aFile: TPas2jsCompilerFile; + Checked: TAVLTree); + + procedure CheckUsesClause(UsesClause: TPasUsesClause); + var + i: Integer; + UsedFile: TPas2jsCompilerFile; + aModule: TPasModule; + begin + if length(UsesClause)=0 then exit; + for i:=0 to length(UsesClause)-1 do begin + aModule:=UsesClause[i].Module as TPasModule; + UsedFile:=TPas2jsCompilerFile.GetFile(aModule); + if UsedFile=nil then + RaiseInternalError(20171214121720,aModule.Name); + CreateJavaScript(UsedFile,Checked); + end; + end; + +begin + if (aFile.JSModule<>nil) or (not aFile.NeedBuild) then exit; + // check each file only once + if Checked.Find(aFile)<>nil then exit; + Checked.Add(aFile); + + Log.LogMsg(nCompilingFile,[FileCache.FormatPath(aFile.PasFilename)],'',0,0, + not (coShowLineNumbers in Options)); + + // convert dependencies + CheckUsesClause(aFile.GetPasMainUsesClause); + CheckUsesClause(aFile.GetPasImplUsesClause); + + aFile.CreateJS; +end; + +procedure TPas2jsCompiler.FinishSrcMap(SrcMap: TPas2JSSrcMap); +var + LocalFilename, MapFilename, BaseDir: String; + aFile: TPas2jsCachedFile; + i: Integer; +begin + if SrcMapBaseDir<>'' then + BaseDir:=SrcMapBaseDir + else + BaseDir:=ExtractFilePath(ExtractFilePath(SrcMap.LocalFilename)); + for i:=0 to SrcMap.SourceCount-1 do begin + LocalFilename:=SrcMap.SourceFiles[i]; + if LocalFilename='' then continue; + if SrcMapInclude then begin + // include source in SrcMap + aFile:=FileCache.LoadTextFile(LocalFilename); + SrcMap.SourceContents[i]:=aFile.Source; + end; + // translate local file name + if BaseDir<>'' then begin + if not TryCreateRelativePath(LocalFilename,BaseDir,true,MapFilename) + then begin + // e.g. file is on another partition + if not SrcMapInclude then begin + Log.Log(mtError, + SafeFormat(sUnableToTranslatePathToDir,[LocalFilename,BaseDir]), + nUnableToTranslatePathToDir); + Terminate(ExitCodeConverterError); + end; + // the source is included, do not translate the filename + MapFilename:=LocalFilename; + end; + {$IFNDEF Unix} + // use / as PathDelim + MapFilename:=StringReplace(MapFilename,PathDelim,'/',[rfReplaceAll]); + {$ENDIF} + SrcMap.SourceTranslatedFiles[i]:=MapFilename; + end; + end; +end; + +function TPas2jsCompiler.DoWriteJSFile(const DestFilename: String; + aWriter: TPas2JSMapper): Boolean; +begin + Result:=False; + if DestFilename='' then ; + if aWriter=nil then ; +end; + +procedure TPas2jsCompiler.WriteJSFiles(aFile: TPas2jsCompilerFile; + var CombinedFileWriter: TPas2JSMapper; Checked: TAVLTree); + + procedure CheckUsesClause(UsesClause: TPasUsesClause); + var + i: Integer; + UsedFile: TPas2jsCompilerFile; + aModule: TPasModule; + begin + if length(UsesClause)=0 then exit; + for i:=0 to length(UsesClause)-1 do begin + aModule:=UsesClause[i].Module as TPasModule; + UsedFile:=TPas2jsCompilerFile.GetFile(aModule); + if UsedFile=nil then + RaiseInternalError(20171214121720,aModule.Name); + WriteJSFiles(UsedFile,CombinedFileWriter,Checked); + end; + end; + +var + aFileWriter: TPas2JSMapper; + FreeWriter: Boolean; + + procedure CreateFileWriter(aFilename: string); + var + SrcMap: TPas2JSSrcMap; + begin + aFileWriter:=TPas2JSMapper.Create(4096); + FreeWriter:=true; + if SrcMapEnable then begin + SrcMap:=TPas2JSSrcMap.Create(ExtractFilename(aFilename)); + aFileWriter.SrcMap:=SrcMap; + SrcMap.Release;// release the refcount from the Create + SrcMap.SourceRoot:=SrcMapSourceRoot; + SrcMap.LocalFilename:=aFile.JSFilename; + end; + end; + +var + DestFilename, DestDir, Src, MapFilename: String; + aJSWriter: TJSWriter; + fs: TFileStream; + ms: TMemoryStream; +begin + //writeln('TPas2jsCompiler.WriteJSFiles ',aFile.PasFilename,' Need=',aFile.NeedBuild,' Checked=',Checked.Find(aFile)<>nil); + if (aFile.JSModule=nil) or (not aFile.NeedBuild) then exit; + // check each file only once + if Checked.Find(aFile)<>nil then exit; + Checked.Add(aFile); + + FreeWriter:=false; + if FileCache.AllJSIntoMainJS and (CombinedFileWriter=nil) then begin + // create CombinedFileWriter + DestFilename:=FileCache.GetResolvedMainJSFile; + CreateFileWriter(DestFilename); + CombinedFileWriter:=aFileWriter; + FileCache.InsertCustomJSFiles(CombinedFileWriter); + end else begin + DestFilename:=aFile.JSFilename; + end; + + // convert dependencies + CheckUsesClause(aFile.GetPasMainUsesClause); + CheckUsesClause(aFile.GetPasImplUsesClause); + + aJSWriter:=nil; + aFileWriter:=CombinedFileWriter; + try + if aFileWriter=nil then begin + // create writer for this file + CreateFileWriter(DestFilename); + if aFile.IsMainFile and not FileCache.AllJSIntoMainJS then + FileCache.InsertCustomJSFiles(aFileWriter); + end; + + // write JavaScript + aJSWriter:=TJSWriter.Create(aFileWriter); + aJSWriter.Options:=[woUseUTF8,woCompactArrayLiterals,woCompactObjectLiterals,woCompactArguments]; + aJSWriter.IndentSize:=2; + aJSWriter.WriteJS(aFile.JSModule); + + if aFile.IsMainFile and (TargetPlatform=PlatformNodeJS) then + aFileWriter.WriteFile('rtl.run();'+LineEnding,aFile.PasFilename); + + // Give chance to descendants to write file + if DoWriteJSFile(aFile.JSFilename,aFileWriter) then + exit;// descendant has written -> finished + + if (aFile.JSFilename='') and (FileCache.MainJSFile='.') then begin + // write to stdout + Log.LogRaw(aFileWriter.AsAnsistring); + end else if FreeWriter then begin + // write to file + + //writeln('TPas2jsCompiler.WriteJSFiles ',aFile.PasFilename,' ',aFile.JSFilename); + Log.LogMsg(nWritingFile,[FileCache.FormatPath(DestFilename)],'',0,0, + not (coShowLineNumbers in Options)); + + // check output directory + DestDir:=ChompPathDelim(ExtractFilePath(DestFilename)); + if (DestDir<>'') and not DirectoryExists(DestDir) then begin + Log.LogMsg(nOutputDirectoryNotFound,[FileCache.FormatPath(DestDir)]); + Terminate(ExitCodeFileNotFound); + end; + if DirectoryExists(DestFilename) then begin + Log.LogMsg(nFileIsFolder,[FileCache.FormatPath(DestFilename)]); + Terminate(ExitCodeWriteError); + end; + + MapFilename:=DestFilename+'.map'; + + // write js + try + fs:=TFileStream.Create(DestFilename,fmCreate); + try + // UTF8-BOM + if (Log.Encoding='') or (Log.Encoding='utf8') then begin + Src:=String(UTF8BOM); + fs.Write(Src[1],length(Src)); + end; + // JS source + fs.Write(aFileWriter.Buffer^,aFileWriter.BufferLength); + // source map comment + if aFileWriter.SrcMap<>nil then begin + Src:='//# sourceMappingURL='+ExtractFilename(MapFilename)+LineEnding; + fs.Write(Src[1],length(Src)); + end; + finally + fs.Free; + end; + except + on E: Exception do begin + Log.LogRaw('Error: '+E.Message); + Log.LogMsg(nUnableToWriteFile,[FileCache.FormatPath(DestFilename)]); + Terminate(ExitCodeWriteError); + end; + end; + + // write source map + if aFileWriter.SrcMap<>nil then begin + Log.LogMsg(nWritingFile,[FileCache.FormatPath(MapFilename)],'',0,0, + not (coShowLineNumbers in Options)); + FinishSrcMap(aFileWriter.SrcMap); + try + ms:=TMemoryStream.Create; + try + // Note: No UTF-8 BOM in source map, Chrome 59 gives an error + aFileWriter.SrcMap.SaveToStream(ms); + ms.Position:=0; + ms.SaveToFile(MapFilename); + finally + ms.Free; + end; + except + on E: Exception do begin + Log.LogRaw('Error: '+E.Message); + Log.LogMsg(nUnableToWriteFile,[FileCache.FormatPath(MapFilename)]); + Terminate(ExitCodeWriteError); + end; + end; + end; + end; + + finally + if FreeWriter then begin + if CombinedFileWriter=aFileWriter then + CombinedFileWriter:=nil; + aFileWriter.Free + end; + aJSWriter.Free; + end; +end; + +procedure TPas2jsCompiler.InitParamMacros; +begin + ParamMacros.AddValue('Pas2jsFullVersion','major.minor.release<extra>',GetVersion(false)); + ParamMacros.AddValue('Pas2jsVersion','major.minor.release',GetVersion(true)); + ParamMacros.AddFunction('Env','environment variable, e.g. $Env(HOME)',@OnMacroEnv,true); + ParamMacros.AddFunction('CfgDir','Use within a config file. The directory of this config file',@OnMacroCfgDir,false); + // Additionally, under windows the following special variables are recognized: + +{ ToDo: + LOCAL_APPDATA + Usually the directory ”Local settings/Application Data” under the user’s home directory. + APPDATA + Usually the directory ”Application Data” under the user’s home directory. + COMMON_APPDATA + Usually the directory ”Application Data” under the ’All users’ directory. + PERSONAL + Usually the ”My documents” directory of the user. + PROGRAM_FILES + Usually ”program files” directory on the system drive + PROGRAM_FILES_COMMON + Usually the ”Common files” directory under the program files directory. + PROFILE + The user’s home directory. } +end; + +procedure TPas2jsCompiler.ClearDefines; +var + i: Integer; + M: TMacroDef; +begin + for i:=0 to FDefines.Count-1 do + begin + M:=TMacroDef(FDefines.Objects[i]); + M.Free; + end; + FDefines.Clear; +end; + +procedure TPas2jsCompiler.RaiseInternalError(id: int64; Msg: string); +begin + Log.LogRaw('['+IntToStr(id)+'] '+Msg); + raise Exception.Create(Msg); +end; + +procedure TPas2jsCompiler.Terminate(TheExitCode: integer); +begin + ExitCode:=TheExitCode; + if Log<>nil then Log.Flush; + raise ECompilerTerminate.Create(''); +end; + +function TPas2jsCompiler.GetShowDebug: boolean; +begin + Result:=coShowDebug in Options; +end; + +function TPas2jsCompiler.GetShowFullPaths: boolean; +begin + Result:=FileCache.ShowFullPaths; +end; + +function TPas2jsCompiler.GetShowLogo: Boolean; +begin + Result:=coShowLogo in FOptions; +end; + +function TPas2jsCompiler.GetShowTriedUsedFiles: boolean; +begin + Result:=FileCache.ShowTriedUsedFiles; +end; + +function TPas2jsCompiler.GetShowUsedTools: boolean; +begin + Result:=coShowUsedTools in Options; +end; + +function TPas2jsCompiler.GetSkipDefaultConfig: Boolean; +begin + Result:=coSkipDefaultConfigs in FOptions; +end; + +function TPas2jsCompiler.GetSrcMapBaseDir: string; +begin + Result:=FileCache.SrcMapBaseDir; +end; + +function TPas2jsCompiler.GetSrcMapEnable: boolean; +begin + Result:=coSourceMapCreate in FOptions; +end; + +function TPas2jsCompiler.GetSrcMapInclude: boolean; +begin + Result:=coSourceMapInclude in FOptions; +end; + +procedure TPas2jsCompiler.LoadConfig(CfgFilename: string); +type + TSkip = ( + skipNone, + skipIf, + skipElse + ); +const + IdentChars = ['a'..'z','A'..'Z','_','0'..'9']; +var + Line: String; + p, StartP: PChar; + + function GetWord: String; + begin + StartP:=p; + while (p^ in IdentChars) or (p^>#127) do inc(p); + Result:=copy(Line,StartP-PChar(Line)+1,p-StartP); + while p^ in [' ',#9] do inc(p); + end; + + procedure DebugCfgDirective(const s: string); + begin + Log.LogMsg(nCfgDirective,[Line,s],CurrentCfgFilename,CurrentCfgLineNumber,1,false); + end; + +var + OldCfgFilename, Directive, aName, Expr: String; + aFile: TPas2jsFileLineReader; + IfLvl, SkipLvl, OldCfgLineNumber: Integer; + Skip: TSkip; +begin + if ShowTriedUsedFiles then + Log.LogMsgIgnoreFilter(nReadingOptionsFromFile,[CfgFilename]); + IfLvl:=0; + SkipLvl:=0; + Skip:=skipNone; + aFile:=nil; + try + OldCfgFilename:=FCurrentCfgFilename; + FCurrentCfgFilename:=CfgFilename; + OldCfgLineNumber:=FCurrentCfgLineNumber; + aFile:=TPas2jsFileLineReader.Create(CfgFilename); + while not aFile.IsEOF do begin + Line:=aFile.ReadLine; + FCurrentCfgLineNumber:=aFile.LineNumber; + if ShowDebug then + Log.LogMsgIgnoreFilter(nInterpretingFileOption,[Line]); + if Line='' then continue; + p:=PChar(Line); + while (p^ in [' ',#9]) do inc(p); + if p^=#0 then continue; // empty line + + if p^='#' then begin + // cfg directive + inc(p); + if p^ in [#0,#9,' ','-'] then continue; // comment + Directive:=lowercase(GetWord); + case Directive of + 'ifdef','ifndef': + begin + inc(IfLvl); + if Skip=skipNone then begin + aName:=GetWord; + if IsDefined(aName)=(Directive='ifdef') then begin + // execute block + if ShowDebug then + DebugCfgDirective('true -> execute'); + end else begin + // skip block + if ShowDebug then + DebugCfgDirective('false -> skip'); + SkipLvl:=IfLvl; + Skip:=skipIf; + end; + end; + end; + 'if': + begin + inc(IfLvl); + if Skip=skipNone then begin + Expr:=copy(Line,p-PChar(Line)+1,length(Line)); + if ConditionEvaluator.Eval(Expr) then begin + // execute block + if ShowDebug then + DebugCfgDirective('true -> execute'); + end else begin + // skip block + if ShowDebug then + DebugCfgDirective('false -> skip'); + SkipLvl:=IfLvl; + Skip:=skipIf; + end; + end; + end; + 'else': + begin + if IfLvl=0 then + CfgSyntaxError('"'+Directive+'" without ifdef'); + if (Skip=skipElse) and (IfLvl=SkipLvl) then + CfgSyntaxError('"there was already an $else');; + if (Skip=skipIf) and (IfLvl=SkipLvl) then begin + // if-block was skipped -> execute else block + if ShowDebug then + DebugCfgDirective('execute'); + SkipLvl:=0; + Skip:=skipNone; + end else if Skip=skipNone then begin + // if-block was executed -> skip else block + if ShowDebug then + DebugCfgDirective('skip'); + Skip:=skipElse; + end; + end; + 'elseif': + begin + if IfLvl=0 then + CfgSyntaxError('"'+Directive+'" without ifdef'); + if (Skip=skipIf) and (IfLvl=SkipLvl) then begin + // if-block was skipped -> try this elseif + Expr:=copy(Line,p-PChar(Line)+1,length(Line)); + if ConditionEvaluator.Eval(Expr) then begin + // execute elseif block + if ShowDebug then + DebugCfgDirective('true -> execute'); + SkipLvl:=0; + Skip:=skipNone; + end else begin + // skip elseif block + if ShowDebug then + DebugCfgDirective('false -> skip'); + end; + end else if Skip=skipNone then begin + // if-block was executed -> skip without test + if ShowDebug then + DebugCfgDirective('no test -> skip'); + Skip:=skipIf; + end; + end; + 'endif': + begin + if IfLvl=0 then + CfgSyntaxError('"'+Directive+'" without ifdef'); + dec(IfLvl); + if IfLvl<SkipLvl then begin + // end block + if ShowDebug then + DebugCfgDirective('end block'); + SkipLvl:=0; + Skip:=skipNone; + end; + end; + 'error': + ParamFatal('user defined: '+copy(Line,p-PChar(Line)+1,length(Line))) + else + if Skip=skipNone then + CfgSyntaxError('unknown directive "'+Directive+'"') + else + DebugCfgDirective('skipping unknown directive'); + end; + end else if Skip=skipNone then begin + // option line + Line:=String(p); + ReadParam(Line,false,false); + end; + end; + finally + FCurrentCfgFilename:=OldCfgFilename; + FCurrentCfgLineNumber:=OldCfgLineNumber; + aFile.Free; + end; + if ShowTriedUsedFiles then + Log.LogMsgIgnoreFilter(nEndOfReadingConfigFile,[CfgFilename]); +end; + +procedure TPas2jsCompiler.LoadDefaultConfig; + + function TryConfig(aFilename: string): boolean; + begin + Result:=false; + if aFilename='' then exit; + aFilename:=ExpandFileNameUTF8(aFilename); + if ShowTriedUsedFiles then + Log.LogMsgIgnoreFilter(nConfigFileSearch,[aFilename]); + if not FileExists(aFilename) then exit; + Result:=true; + LoadConfig(aFilename); + end; + +var + aFilename: String; +begin + // first try HOME directory + aFilename:=ChompPathDelim(GetEnvironmentVariableUTF8('HOME')); + if aFilename<>'' then + if TryConfig(aFilename+PathDelim+DefaultConfigFile) then exit; + + // then try compiler directory + if (CompilerExe<>'') then begin + aFilename:=ExtractFilePath(CompilerExe); + if aFilename<>'' then begin + aFilename:=IncludeTrailingPathDelimiter(aFilename)+DefaultConfigFile; + if TryConfig(aFilename) then exit; + end; + end; + + // finally try global directory + {$IFDEF Unix} + if TryConfig('/etc/'+DefaultConfigFile) then exit; + {$ENDIF} +end; + +procedure TPas2jsCompiler.ParamFatal(Msg: string); +begin + Log.LogRaw(['Fatal: ',Msg]); + Terminate(ExitCodeErrorInParams); +end; + +procedure TPas2jsCompiler.ReadParam(Param: string; Quick, FromCmdLine: boolean); + + procedure UnknownParam; + begin + ParamFatal('unknown parameter "'+Param+'". Use -h for help.'); + end; + +var + p: PChar; + EnabledFlags, DisabledFlags, Identifier, Value, aFilename, ErrorMsg: string; + i: Integer; + c: Char; + aProc: TPasToJsProcessor; + Enable: Boolean; + aPlatform: TPasToJsPlatform; +begin + if ShowDebug then + if Quick then + Log.LogMsgIgnoreFilter(nQuickHandlingOption,[Param]) + else + Log.LogMsgIgnoreFilter(nHandlingOption,[Param]); + if Param='' then exit; + ParamMacros.Substitute(Param,Self); + if Param='' then exit; + + if Quick and ((Param='-h') or (Param='-?') or (Param='--help')) then begin + WriteHelp; + Terminate(0); + end; + + p:=PChar(Param); + case p^ of + '-': + begin + inc(p); + case p^ of + 'i': + begin + // write information and halt + for i:=3 to length(Param) do begin + case Param[i] of + 'V': // write short version + Log.LogRaw(GetVersion(true)); + 'W': // write long version + Log.LogRaw(GetVersion(false)); + else + ParamFatal('unknown info option "'+Param[i]+'" in "'+Param+'".'); + end; + end; + Terminate(0); + end; + 'B','l','n': + begin + ReadSingleLetterOptions(Param,p,'Bln',EnabledFlags,DisabledFlags); + for i:=1 to length(EnabledFlags) do begin + case EnabledFlags[i] of + 'B': Options:=Options+[coBuildAll]; + 'l': ShowLogo:=true; + 'n': SkipDefaultConfig:=true; + end; + end; + for i:=1 to length(DisabledFlags) do begin + case DisabledFlags[i] of + 'B': Options:=Options-[coBuildAll]; + 'l': ShowLogo:=false; + 'n': SkipDefaultConfig:=false; + end; + end; + end; + 'd': // define + if not Quick then begin + Identifier:=copy(Param,3,length(Param)); + i:=Pos(':=',Identifier); + if i>0 then begin + Value:=copy(Identifier,i+2,length(Identifier)); + Identifier:=LeftStr(Identifier,i-1); + if not IsValidIdent(Identifier) then + ParamFatal('invalid define: "'+Param+'"'); + AddDefine(Identifier,Value); + end else begin + if not IsValidIdent(Identifier) then + ParamFatal('invalid define: "'+Param+'"'); + AddDefine(Identifier); + end; + end; + 'F': // folders and search paths + begin + inc(p); + c:=p^; + inc(p); + case c of + 'e': Log.OutputFilename:=String(p); + 'i': if not FileCache.AddIncludePaths(String(p),FromCmdLine,ErrorMsg) then + ParamFatal('invalid include path "'+ErrorMsg+'"'); + 'u': if not FileCache.AddUnitPaths(String(p),FromCmdLine,ErrorMsg) then + ParamFatal('invalid unit path "'+ErrorMsg+'"'); + 'U': FileCache.UnitOutputPath:=String(p); + else UnknownParam; + end; + end; + 'I': // include path, same as -Fi + if not Quick then begin + inc(p); + if not FileCache.AddIncludePaths(String(p),FromCmdLine,ErrorMsg) then + ParamFatal('invalid include path "'+ErrorMsg+'"'); + end; + 'J': // extra pas2js options + begin + inc(p); + c:=p^; + inc(p); + case c of + 'c': FileCache.AllJSIntoMainJS:=p^<>'-'; + 'i': + if p^=#0 then + ParamFatal('missing insertion file: '+Param) + else if not Quick then begin + aFilename:=String(p); + if aFilename='' then + UnknownParam; + if aFilename[length(aFilename)]='-' then begin + Delete(aFilename,length(aFilename),1); + if aFilename='' then + UnknownParam; + FileCache.RemoveInsertFilename(aFilename); + end else + FileCache.AddInsertFilename(aFilename); + end; + 'l': SetOption(coLowerCase,p^<>'-'); + 'm': + // source map options + if p^=#0 then + SrcMapEnable:=true + else if p^='-' then + begin + if p[1]<>#0 then + UnknownParam; + SrcMapEnable:=false; + end + else + begin + Value:=String(p); + if Value='include' then + SrcMapInclude:=true + else if Value='include-' then + SrcMapInclude:=false + else + begin + i:=Pos('=',Value); + if i<1 then + UnknownParam; + Identifier:=LeftStr(Value,i-1); + Delete(Value,1,i); + if Identifier='sourceroot' then + SrcMapSourceRoot:=Value + else if Identifier='basedir' then + SrcMapBaseDir:=Value + else + UnknownParam; + end; + // enable source maps when setting any -Jm<x> option + SrcMapEnable:=true; + end; + 'u': + if not Quick then + if not FileCache.AddSrcUnitPaths(String(p),FromCmdLine,ErrorMsg) then + ParamFatal('invalid foreign unit path "'+ErrorMsg+'"'); + 'e': + begin + Identifier:=NormalizeEncoding(String(p)); + case Identifier of + 'console','system','utf8': Log.Encoding:=Identifier; + else ParamFatal('invalid encoding "'+String(p)+'"'); + end; + end + else UnknownParam; + end; + end; + 'M': // syntax mode + begin + inc(p); + Identifier:=String(p); + if CompareText(Identifier,'delphi')=0 then Mode:=p2jmDelphi + else if CompareText(Identifier,'objfpc')=0 then Mode:=p2jmObjFPC + else ParamFatal('invalid syntax mode "'+Identifier+'"'); + end; + 'N': + begin + inc(p); + case p^ of + 'S': if not FileCache.AddNamespaces(String(p+1),FromCmdLine,ErrorMsg) then + ParamFatal('invalid namespace "'+ErrorMsg+'"'); + else UnknownParam; + end; + end; + 'o': // output file, main JavaScript file + begin + inc(p); + FileCache.MainJSFile:=String(p); + end; + 'O': // optimizations + begin + inc(p); + case p^ of + '-': + begin + inc(p); + Options:=Options-coO1Enable+coO1Disable; + end; + '1': + begin + inc(p); + Options:=Options+coO1Enable-coO1Disable; + end; + 'o': + begin + inc(p); + Identifier:=String(p); + if Identifier='' then UnknownParam; + inc(p,length(Identifier)); + Enable:=true; + c:=Identifier[length(Identifier)]; + if c in ['+','-'] then begin + Enable:=c='+'; + Delete(Identifier,length(Identifier),1); + end; + if CompareText(Identifier,'EnumNumbers')=0 then + SetOption(coEnumValuesAsNumbers,Enable) + else if CompareText(Identifier,'RemoveNotUsedPrivates')=0 then + SetOption(coKeepNotUsedPrivates,not Enable) + else if CompareText(Identifier,'RemoveNotUsedDeclarations')=0 then + SetOption(coKeepNotUsedDeclarationsWPO,not Enable) + else + UnknownParam; + end; + else + UnknownParam; + end; + if p-PChar(Param)<length(Param) then + UnknownParam; + end; + 'P': // target processor + begin + inc(p); + Identifier:=String(p); + for aProc in TPasToJsProcessor do + if CompareText(Identifier,PasToJsProcessorNames[aProc])=0 then + begin + TargetProcessor:=aProc; + Identifier:=''; + break; + end; + if Identifier<>'' then + ParamFatal('invalid target processor "'+Identifier+'"'); + end; + 'S': // Syntax + begin + inc(p); + ReadSyntaxFlags(Param,p); + end; + 'T': // target platform + begin + inc(p); + Identifier:=String(p); + for aPlatform in TPasToJsPlatform do + if CompareText(Identifier,PasToJsPlatformNames[aPlatform])=0 then + begin + TargetPlatform:=aPlatform; + Identifier:=''; + break; + end; + if Identifier<>'' then + ParamFatal('invalid target platform "'+Identifier+'"'); + end; + 'u': // undefine + if not Quick then begin + Identifier:=copy(Param,3,length(Param)); + if not IsValidIdent(Identifier) then + ParamFatal('-u: invalid undefine: "'+Param+'"'); + RemoveDefine(Identifier); + end; + 'v': // verbose + begin + inc(p); + ReadVerbosityFlags(Param,p); + end; + else + UnknownParam; + end; + end; + '@': + if not Quick then begin + // load extra config file + aFilename:=copy(Param,2,length(Param)); + if aFilename='' then + ParamFatal('invalid config file at param position '+IntToStr(i)); + aFilename:=ExpandFileNameUTF8(aFilename); + if not FileExists(aFilename) then + ParamFatal('config file not found: "'+copy(Param,2,length(Param))+'"'); + LoadConfig(aFilename); + end; + else + // filename + if (not Quick) then begin + if not FromCmdLine then + CfgSyntaxError('invalid parameter'); + if FileCache.MainSrcFile<>'' then + ParamFatal('Two Pascal files. Only one Pascal file is supported.'); + aFilename:=ExpandFileNameUTF8(Param); + if not FileExists(aFilename) then + ParamFatal('Pascal file not found: "'+Param+'"'); + FileCache.MainSrcFile:=aFilename; + end; + end; +end; + +procedure TPas2jsCompiler.ReadVerbosityFlags(Param: String; p: PChar); +var + Enabled, Disabled: string; + i: Integer; +begin + if p^='m' then begin + // read m-flags + repeat + inc(p); + if not (p^ in ['0'..'9']) then + ParamFatal('missing number in "'+Param+'"'); + i:=0; + while p^ in ['0'..'9'] do begin + i:=i*10+ord(p^)-ord('0'); + if i>99999 then + ParamFatal('Invalid -vm parameter in "'+Param+'"'); + inc(p); + end; + Log.MsgNumberDisabled[i]:=p^<>'-'; + if p^='-' then inc(p); + if p^=#0 then break; + if p^<>',' then + ParamFatal('Invalid option "'+Param+'"'); + until false; + exit; + end; + + // read other flags + ReadSingleLetterOptions(Param,p,'ewnhila0bctdqxz',Enabled,Disabled); + for i:=1 to length(Enabled) do begin + case Enabled[i] of + 'e': Options:=Options+[coShowErrors]; + 'w': Options:=Options+[coShowWarnings]; + 'n': Options:=Options+[coShowNotes]; + 'h': Options:=Options+[coShowHints]; + 'i': Options:=Options+[coShowInfos]; + 'l': Options:=Options+[coShowLineNumbers]; + 'a': Options:=Options+coShowAll; + '0': Options:=Options-coShowAll+[coShowErrors]; + 'b': ShowFullPaths:=true; + 'c': Options:=Options+[coShowConditionals,coShowInfos]; + 't': ShowTriedUsedFiles:=true; + 'd': ShowDebug:=true; + 'q': Options:=Options+[coShowMessageNumbers]; + 'x': Options:=Options+[coShowUsedTools]; + end; + end; + for i:=1 to length(Disabled) do begin + case Disabled[i] of + 'e': Options:=Options-[coShowErrors]; + 'w': Options:=Options-[coShowWarnings]; + 'n': Options:=Options-[coShowNotes]; + 'h': Options:=Options-[coShowHints]; + 'i': Options:=Options-[coShowInfos]; + 'l': Options:=Options-[coShowLineNumbers]; + 'a': ; + '0': ; + 'b': ShowFullPaths:=false; + 'c': Options:=Options-[coShowConditionals]; + 't': ShowTriedUsedFiles:=false; + 'd': ShowDebug:=false; + 'q': Options:=Options-[coShowMessageNumbers]; + 'x': Options:=Options-[coShowUsedTools]; + end; + end; +end; + +procedure TPas2jsCompiler.ReadSyntaxFlags(Param: String; p: PChar); +var + Enabled, Disabled: string; + i: Integer; +begin + ReadSingleLetterOptions(Param,p,'c',Enabled,Disabled); + for i:=1 to length(Enabled) do begin + case Enabled[i] of + '2': Mode:=p2jmObjFPC; + 'c': Options:=Options+[coAllowCAssignments]; + 'd': Mode:=p2jmDelphi; + end; + end; + for i:=1 to length(Disabled) do begin + case Disabled[i] of + '2': ; + 'c': Options:=Options-[coAllowCAssignments]; + 'd': ; + end; + end; +end; + +procedure TPas2jsCompiler.ReadSingleLetterOptions(const Param: string; p: PChar; + const Allowed: string; out Enabled, Disabled: string); +// e.g. 'B' 'lB' 'l-' 'l+B-' +var + Letter: Char; + i: SizeInt; +begin + if p^=#0 then + ParamFatal('Invalid option "'+Param+'"'); + Enabled:=''; + Disabled:=''; + repeat + Letter:=p^; + if Letter='-' then + ParamFatal('Invalid option "'+Param+'"'); + if Pos(Letter,Allowed)<1 then + ParamFatal('unknown option "'+Param+'". Use -h for help.'); + inc(p); + if p^='-' then begin + // disable + if Pos(Letter,Disabled)<1 then Disabled+=Letter; + i:=Pos(Letter,Enabled); + if i>0 then Delete(Enabled,i,1); + inc(p); + end else begin + // enable + if Pos(Letter,Enabled)<1 then Enabled+=Letter; + i:=Pos(Letter,Disabled); + if i>0 then Delete(Disabled,i,1); + if p^='+' then inc(p); + end; + until p^=#0; +end; + +procedure TPas2jsCompiler.RegisterMessages; +var + LastMsgNumber: integer; + + procedure r(MsgType: TMessageType; MsgNumber: integer; const MsgPattern: string); + var + s: String; + begin + if (LastMsgNumber>=0) and (MsgNumber<>LastMsgNumber+1) then + begin + s:='TPas2jsCompiler.RegisterMessages: gap in registered message numbers: '+IntToStr(LastMsgNumber)+' '+IntToStr(MsgNumber); + RaiseInternalError(20170504161422,s); + end; + Log.RegisterMsg(MsgType,MsgNumber,MsgPattern); + LastMsgNumber:=MsgNumber; + end; + +begin + LastMsgNumber:=-1; + r(mtInfo,nOptionIsEnabled,sOptionIsEnabled); + r(mtInfo,nSyntaxModeIs,sSyntaxModeIs); + r(mtInfo,nMacroDefined,sMacroDefined); + r(mtInfo,nUsingPath,sUsingPath); + r(mtNote,nFolderNotFound,sFolderNotFound); + r(mtInfo,nNameValue,sNameValue); + r(mtInfo,nReadingOptionsFromFile,sReadingOptionsFromFile); + r(mtInfo,nEndOfReadingConfigFile,sEndOfReadingConfigFile); + r(mtDebug,nInterpretingFileOption,sInterpretingFileOption); + r(mtFatal,nSourceFileNotFound,sSourceFileNotFound); + r(mtFatal,nFileIsFolder,sFileIsFolder); + r(mtInfo,nConfigFileSearch,sConfigFileSearch); + r(mtDebug,nHandlingOption,sHandlingOption); + r(mtDebug,nQuickHandlingOption,sQuickHandlingOption); + r(mtFatal,nOutputDirectoryNotFound,sOutputDirectoryNotFound); + r(mtInfo,nUnableToWriteFile,sUnableToWriteFile); + r(mtInfo,nWritingFile,sWritingFile); + r(mtFatal,nCompilationAborted,sCompilationAborted); + r(mtDebug,nCfgDirective,sCfgDirective); + r(mtError,nUnitCycle,sUnitCycle); + r(mtError,nOptionForbidsCompile,sOptionForbidsCompile); + r(mtInfo,nUnitNeedsCompileDueToUsedUnit,sUnitsNeedCompileDueToUsedUnit); + r(mtInfo,nUnitNeedsCompileDueToOption,sUnitsNeedCompileDueToOption); + r(mtInfo,nUnitNeedsCompileJSMissing,sUnitsNeedCompileJSMissing); + r(mtInfo,nUnitNeedsCompilePasHasChanged,sUnitsNeedCompilePasHasChanged); + r(mtInfo,nParsingFile,sParsingFile); + r(mtInfo,nCompilingFile,sCompilingFile); + r(mtError,nExpectedButFound,sExpectedButFound); + r(mtInfo,nLinesInFilesCompiled,sLinesInFilesCompiled); + r(mtInfo,nTargetPlatformIs,sTargetPlatformIs); + r(mtInfo,nTargetProcessorIs,sTargetProcessorIs); + r(mtInfo,nMessageEncodingIs,sMessageEncodingIs); + r(mtError,nUnableToTranslatePathToDir,sUnableToTranslatePathToDir); + r(mtInfo,nSrcMapSourceRootIs,sSrcMapSourceRootIs); + r(mtInfo,nSrcMapBaseDirIs,sSrcMapBaseDirIs); + Pas2jsPParser.RegisterMessages(Log); +end; + +procedure TPas2jsCompiler.SetCompilerExe(AValue: string); +begin + if AValue<>'' then + AValue:=ExpandFileNameUTF8(AValue); + if FCompilerExe=AValue then Exit; + FCompilerExe:=AValue; +end; + +procedure TPas2jsCompiler.SetMode(AValue: TP2jsMode); +begin + if FMode=AValue then Exit; + FMode:=AValue; + case FMode of + p2jmObjFPC: Options:=Options-[coAllowCAssignments]; + p2jmDelphi: Options:=Options-[coAllowCAssignments]; + end; +end; + +procedure TPas2jsCompiler.SetOptions(AValue: TP2jsCompilerOptions); +begin + if FOptions=AValue then Exit; + FOptions:=AValue; + Log.ShowMsgNumbers:=coShowMessageNumbers in FOptions; + Log.ShowMsgTypes:=GetShownMsgTypes; +end; + +procedure TPas2jsCompiler.SetShowDebug(AValue: boolean); +begin + if AValue then + FOptions:=FOptions+[coShowNotes,coShowInfos,coShowDebug] + else + Exclude(FOptions,coShowNotes); +end; + +procedure TPas2jsCompiler.SetShowFullPaths(AValue: boolean); +begin + FileCache.ShowFullPaths:=AValue; +end; + +procedure TPas2jsCompiler.SetShowLogo(AValue: Boolean); +begin + SetOption(coShowLogo,AValue); +end; + +procedure TPas2jsCompiler.SetShowTriedUsedFiles(AValue: boolean); +begin + FileCache.ShowTriedUsedFiles:=AValue; +end; + +procedure TPas2jsCompiler.SetShowUsedTools(AValue: boolean); +begin + SetOption(coShowUsedTools,AValue); +end; + +procedure TPas2jsCompiler.SetSkipDefaultConfig(AValue: Boolean); +begin + SetOption(coSkipDefaultConfigs,AValue); +end; + +procedure TPas2jsCompiler.SetSrcMapBaseDir(const AValue: string); +begin + FileCache.SrcMapBaseDir:=AValue; +end; + +procedure TPas2jsCompiler.SetSrcMapEnable(const AValue: boolean); +begin + SetOption(coSourceMapCreate,AValue); +end; + +procedure TPas2jsCompiler.SetSrcMapInclude(const AValue: boolean); +begin + SetOption(coSourceMapInclude,AValue); +end; + +procedure TPas2jsCompiler.SetTargetPlatform(const AValue: TPasToJsPlatform); +begin + if FTargetPlatform=AValue then Exit; + RemoveDefine(PasToJsPlatformNames[TargetPlatform]); + FTargetPlatform:=AValue; + if FTargetPlatform=PlatformNodeJS then + FileCache.AllJSIntoMainJS:=true; + AddDefinesForTargetPlatform; +end; + +procedure TPas2jsCompiler.SetTargetProcessor(const AValue: TPasToJsProcessor); +begin + if FTargetProcessor=AValue then Exit; + RemoveDefine(PasToJsProcessorNames[TargetProcessor]); + FTargetProcessor:=AValue; + AddDefinesForTargetProcessor; +end; + +constructor TPas2jsCompiler.Create; +begin + FOptions:=DefaultP2jsCompilerOptions; + FLog:=TPas2jsLogger.Create; + FParamMacros:=TPas2jsMacroEngine.Create; + RegisterMessages; + + FFileCache:=TPas2jsFilesCache.Create(Log); + FFileCacheAutoFree:=true; + FLog.OnFormatPath:=@FileCache.FormatPath; + + FDefines:=TStringList.Create; + // Done by Reset: TStringList(FDefines).Sorted:=True; + // Done by Reset: TStringList(FDefines).Duplicates:=dupError; + + FConditionEval:=TCondDirectiveEvaluator.Create; + FConditionEval.OnLog:=@ConditionEvalLog; + FConditionEval.OnEvalVariable:=@ConditionEvalVariable; + //FConditionEval.OnEvalFunction:=@ConditionEvalFunction; + + FFiles:=TAVLTree.Create(@CompareCompilerFilesPasFile); + FUnits:=TAVLTree.Create(@CompareCompilerFilesPasUnitname); + + InitParamMacros; + Reset; +end; + +destructor TPas2jsCompiler.Destroy; +begin + FreeAndNil(FWPOAnalyzer); + + FMainFile:=nil; + FreeAndNil(FUnits); + FFiles.FreeAndClear; + FreeAndNil(FFiles); + + ClearDefines; + FreeAndNil(FDefines); + FreeAndNil(FConditionEval); + + FLog.OnFormatPath:=nil; + if FFileCacheAutoFree then + FreeAndNil(FFileCache) + else + FFileCache:=nil; + + FreeAndNil(FParamMacros); + FreeAndNil(FLog); + inherited Destroy; +end; + +function TPas2jsCompiler.OnMacroCfgDir(Sender: TObject; var Params: string; + Lvl: integer): boolean; +begin + if Lvl=0 then ; + Params:=ExtractFilePath(CurrentCfgFilename); + Result:=true; +end; + +function TPas2jsCompiler.OnMacroEnv(Sender: TObject; var Params: string; + Lvl: integer): boolean; +begin + if Lvl=0 then ; + Params:=GetEnvironmentVariableUTF8(Params); + Result:=true; +end; + +procedure TPas2jsCompiler.AddDefine(const aName: String); +begin + if FDefines.IndexOf(aName)>=0 then exit; + FDefines.Add(aName); +end; + +procedure TPas2jsCompiler.AddDefine(const aName, Value: String); +var + Index: Integer; + M: TMacroDef; +begin + Index:=FDefines.IndexOf(aName); + If (Index<0) then + FDefines.AddObject(aName,TMacroDef.Create(aName,Value)) + else begin + M:=TMacroDef(FDefines.Objects[Index]); + if M=nil then + FDefines.Objects[Index]:=TMacroDef.Create(aName,Value) + else + M.Value:=Value; + end; +end; + +procedure TPas2jsCompiler.RemoveDefine(const aName: String); +var + i: Integer; + M: TMacroDef; +begin + i:=FDefines.IndexOf(aName); + if (i<>-1) then begin + M:=TMacroDef(FDefines.Objects[i]); + M.Free; + FDefines.Delete(i); + end; +end; + +function TPas2jsCompiler.IsDefined(const aName: String): boolean; +begin + Result:=FDefines.IndexOf(aName)>=0; +end; + +class function TPas2jsCompiler.GetVersion(ShortVersion: boolean): string; +begin + Result:=IntToStr(VersionMajor)+'.'+IntToStr(VersionMinor)+'.'+IntToStr(VersionRelease); + if not ShortVersion then + Result+=VersionExtra; +end; + +procedure TPas2jsCompiler.Reset; +begin + FreeAndNil(FWPOAnalyzer); + + FMainFile:=nil; + FUnits.Clear; + FFiles.FreeAndClear; + + FCompilerExe:=''; + FOptions:=DefaultP2jsCompilerOptions; + FMode:=p2jmObjFPC; + FTargetPlatform:=PlatformBrowser; + FTargetProcessor:=ProcessorECMAScript5; + + Log.Reset; + Log.ShowMsgTypes:=GetShownMsgTypes; + + ClearDefines; + TStringList(FDefines).Sorted:=True; + TStringList(FDefines).Duplicates:=dupError; + + AddDefine('PAS2JS'); + AddDefine('PAS2JS_FULLVERSION',IntToStr((VersionMajor*100+VersionMinor)*100+VersionRelease)); + AddDefinesForTargetPlatform; + AddDefinesForTargetProcessor; + // add FPC compatibility flags + AddDefine('FPC_HAS_FEATURE_CLASSES'); + AddDefine('FPC_HAS_FEATURE_DYNARRAYS'); + AddDefine('FPC_HAS_FEATURE_EXCEPTIONS'); + AddDefine('FPC_HAS_FEATURE_EXITCODE'); + AddDefine('FPC_HAS_FEATURE_INITFINAL'); + AddDefine('FPC_HAS_FEATURE_RTTI'); + AddDefine('FPC_HAS_FEATURE_SUPPORT'); + AddDefine('FPC_HAS_FEATURE_UNICODESTRINGS'); + AddDefine('FPC_HAS_FEATURE_WIDESTRINGS'); + AddDefine('FPC_HAS_TYPE_DOUBLE'); + AddDefine('FPC_HAS_UNICODESTRING'); + AddDefine('FPC_UNICODESTRINGS'); + AddDefine('FPC_WIDESTRING_EQUAL_UNICODESTRING'); + AddDefine('STR_CONCAT_PROCS'); + AddDefine('UNICODE'); + + FHasShownLogo:=false; + FFileCache.Reset; +end; + +procedure TPas2jsCompiler.Run(aCompilerExe: string; aWorkingDir: string; + ParamList: TStrings; DoReset: boolean); +var + i: Integer; + StartTime: TDateTime; +begin + StartTime:=Now; + + if DoReset then Reset; + if FileCount>0 then + RaiseInternalError(20170504161340,'internal error: TPas2jsCompiler.Run FileCount>0'); + + CompilerExe:=aCompilerExe; + FileCache.BaseDirectory:=aWorkingDir; + + // quick check command line params + for i:=0 to ParamList.Count-1 do + ReadParam(ParamList[i],true,true); + if ShowLogo then + WriteLogo; + + // read default config + if not SkipDefaultConfig then + LoadDefaultConfig; + + // read command line parameters + for i:=0 to ParamList.Count-1 do + ReadParam(ParamList[i],false,true); + + // now we know, if the logo can be displayed + if ShowLogo then + WriteLogo; + + // show debug info + if ShowDebug then begin + WriteOptions; + WriteDefines; + end; + if ShowDebug or ShowTriedUsedFiles then + WriteFoldersAndSearchPaths; + + if FileCache.MainSrcFile='' then + ParamFatal('No source file name in command line'); + + // compile + try + Compile(StartTime); + except + on E: ECompilerTerminate do ; + end; +end; + +procedure TPas2jsCompiler.WriteHelp; +const + MaxLineLen = 78; + Indent = 12; + + procedure l(s: string); + var + p, LastCharStart, WordBreak: PChar; + Len: integer; + CodePointCount: Integer; + + procedure InitLine; + begin + p:=PChar(s); + LastCharStart:=p; + WordBreak:=nil; + CodePointCount:=0; + end; + + begin + if length(s)<=MaxLineLen then begin + Log.LogRaw(s); + exit; + end; + InitLine; + repeat + case p^ of + #0: + if p-PChar(s)=length(s) then + break + else + inc(p); + 'a'..'z','A'..'Z','0'..'9','_','-','.',',','"','''','`',#128..#255: + begin + LastCharStart:=p; + Len:=UTF8CharacterStrictLength(p); + if Len=0 then Len:=1; + inc(p,Len); + end; + else + LastCharStart:=p; + WordBreak:=p; + inc(p); + end; + inc(CodePointCount); + if CodePointCount>=MaxLineLen then begin + if (WordBreak=nil) or (WordBreak-PChar(s)<MaxLineLen div 3) then + WordBreak:=LastCharStart; + Len:=WordBreak-PChar(s); + Log.LogRaw(LeftStr(s,Len)); + Delete(s,1,len); + s:=Space(Indent)+Trim(s); + InitLine; + end; + until false; + Log.LogRaw(s); + end; + +var + i: Integer; + ParamMacro: TPas2jsMacro; +begin + WriteLogo; + Log.LogLn; + if CompilerExe<>'' then begin + l('Usage: '+CompilerExe+' <your.pas>'); + end else begin + l('Usage: pas2js <your.pas>'); + end; + Log.LogLn; + l('Options:'); + l('Put + after a boolean switch option to enable it, - to disable it'); + l(' @<x> : Read compiler options from file <x> in addition to the default '+DefaultConfigFile); + l(' -B : Rebuild all'); + l(' -d<x> : Defines the symbol <x>. Optional: -d<x>:=<value>'); + l(' -i<x> : Write information and halt. <x> is a combination of the following letters:'); + l(' V : Write short compiler version'); + l(' W : Write full compiler version'); + l(' -F... Set file names and paths:'); + l(' -Fe<x> : Redirect output to <x>. UTF-8 encoded.'); + l(' -Fi<x> : Add <x> to include paths'); + l(' -Fu<x> : Add <x> to unit paths'); + l(' -FU<x> : Set unit output path to <x>'); + l(' -I<x> : Add <x> to include paths, same as -Fi'); + l(' -J... Extra options of pas2js'); + l(' -Jc : Write all JavaScript concatenated into the output file'); + l(' -Je<x> : Encode messages as <x>.'); + l(' -Jeconsole : Console codepage. This is the default.'); + l(' -Jesystem : System codepage. On non Windows console and system are the same.'); + l(' -Jeutf-8 : Unicode UTF-8. Default when using -Fe.'); + l(' -Ji<x> : Insert JS file <x> into main JS file. E.g. -Jirtl.js. Can be given multiple times. To remove a file name append a minus, e.g. -Jirtl.js-.'); + l(' -Jl : lower case identifiers'); + l(' -Jm : generate source maps'); + l(' -Jmsourceroot=<x> : use x as "sourceRoot", prefix URL for source file names.'); + l(' -Jmbasedir=<x> : write source file names relative to directory x.'); + l(' -Jminclude : include Pascal sources in source map.'); + l(' -Jm- : disable generating source maps'); + l(' -Ju<x> : Add <x> to foreign unit paths. Foreign units are not compiled.'); + //l(' -Jg<x> : Add <x> to group paths. A "-" starts a new group.'); + //l(' -JU<x> : Set unit output path of current group to <y>'); + l(' -l : Write logo'); + l(' -MDelphi: Delphi 7 compatibility mode'); + l(' -MObjFPC: FPC''s Object Pascal compatibility mode (default)'); + l(' -NS<x> : add <x> to namespaces. Namespaces with trailing - are removed.'); + l(' Delphi calls this flag "unit scope names".'); + l(' -n : Do not read the default config files'); + l(' -o<x> : Change main JavaScript file to <x>, "." means stdout'); + l(' -O<x> : Optimizations:'); + l(' -O- : Disable optimizations'); + l(' -O1 : Level 1 optimizations (quick and debugger friendly)'); + //l(' -O2 : Level 2 optimizations (Level 1 + not debugger friendly)'); + l(' -Oo<x> : Enable or disable optimization. The x is case insensitive:'); + l(' -OoEnumNumbers[-] : write enum value as number instead of name. Default in -O1.'); + l(' -OoRemoveNotUsedPrivates[-] : Default is enabled'); + l(' -OoRemoveNotUsedDeclarations[-] : Default enabled for programs with -Jc'); + l(' -P<x> : Set target processor. Case insensitive:'); + l(' -Pecmascript5 : default'); + l(' -Pecmascript6'); + l(' -S<x> : Syntax options. <x> is a combination of the following letters:'); + l(' c : Support operators like C (*=,+=,/= and -=)'); + l(' d : Same as -Mdelphi'); + l(' 2 : Same as -Mobjfpc (default)'); + l(' -T<x> : Set target platform'); + l(' -Tbrowser : default'); + l(' -Tnodejs : add pas.run(), includes -Jc'); + l(' -u<x> : Undefines the symbol <x>'); + l(' -v<x> : Be verbose. <x> is a combination of the following letters:'); + l(' e : show errors (default)'); + l(' w : show warnings'); + l(' n : show notes'); + l(' h : show hints'); + l(' i : show info'); + l(' l : show line numbers'); + l(' a : show everything'); + l(' 0 : show nothing (except errors)'); + l(' b : show file names with full path'); + l(' c : show conditionals'); + l(' t : show tried/used files'); + l(' d : show debug notes and info, enables -vni'); + l(' q : show message numbers'); + l(' x : show used tools'); + l(' -vm<x>,<y>: Do not show messages numbered <x> and <y>.'); + l(' -? : Show this help'); + l(' -h : Show this help'); + Log.LogLn; + l('Macros: $Name, $Name$ or $Name()'); + for i:=0 to ParamMacros.Count-1 do begin + ParamMacro:=ParamMacros[i]; + Log.LogRaw([' $',ParamMacro.Name,BoolToStr(ParamMacro.CanHaveParams,'()',''),': ',ParamMacro.Description]); + end; +end; + +procedure TPas2jsCompiler.WriteLogo; +begin + if FHasShownLogo then exit; + FHasShownLogo:=true; + Log.LogRaw('Pas2JS Compiler version '+GetVersion(false)); + Log.LogRaw('Copyright (c) 2017 Mattias Gaertner and others'); +end; + +procedure TPas2jsCompiler.WriteOptions; +var + co: TP2jsCompilerOption; + fco: TP2jsFileCacheOption; +begin + // boolean options + for co in TP2jsCompilerOption do + Log.LogMsgIgnoreFilter(nOptionIsEnabled, + [p2jscoCaption[co],BoolToStr(co in Options,'enabled','disabled')]); + for fco in TP2jsFileCacheOption do + Log.LogMsgIgnoreFilter(nOptionIsEnabled, + [p2jsfcoCaption[fco],BoolToStr(fco in FileCache.Options,'enabled','disabled')]); + + // default syntax mode + Log.LogMsgIgnoreFilter(nSyntaxModeIs,[p2jscModeNames[Mode]]); + // target platform + Log.LogMsgIgnoreFilter(nTargetPlatformIs,[PasToJsPlatformNames[TargetPlatform]]); + Log.LogMsgIgnoreFilter(nTargetProcessorIs,[PasToJsProcessorNames[TargetProcessor]]); + // message encoding + Log.LogMsgIgnoreFilter(nMessageEncodingIs,[IntToStr(Log.MsgCount)]); + // source map options + if SrcMapEnable then begin + Log.LogMsgIgnoreFilter(nSrcMapSourceRootIs,[SrcMapSourceRoot]); + Log.LogMsgIgnoreFilter(nSrcMapBaseDirIs,[SrcMapBaseDir]); + end; +end; + +procedure TPas2jsCompiler.WriteDefines; +var + i: Integer; + S: String; + M: TMacroDef; +begin + for i:=0 to Defines.Count-1 do + begin + S:=Defines[i]; + M:=TMacroDef(Defines.Objects[i]); + if M<>nil then + S:=S+'='+M.Value; + Log.LogMsgIgnoreFilter(nMacroDefined,[S]); + end; +end; + +procedure TPas2jsCompiler.WriteFoldersAndSearchPaths; + + procedure WriteFolder(aName, Folder: string); + begin + if Folder='' then exit; + Log.LogMsgIgnoreFilter(nUsingPath,[aName,Folder]); + if not DirectoryExists(ChompPathDelim(Folder)) then + Log.LogMsgIgnoreFilter(nFolderNotFound,[aName,Folder]); + end; + +var + i: Integer; +begin + for i:=0 to FileCache.ForeignUnitPaths.Count-1 do + WriteFolder('foreign unit path',FileCache.ForeignUnitPaths[i]); + for i:=0 to FileCache.UnitPaths.Count-1 do + WriteFolder('unit path',FileCache.UnitPaths[i]); + for i:=0 to FileCache.IncludePaths.Count-1 do + WriteFolder('include path',FileCache.IncludePaths[i]); + WriteFolder('unit output path',FileCache.UnitOutputPath); + Log.LogMsgIgnoreFilter(nNameValue,['output file',FileCache.MainJSFile]); +end; + +function TPas2jsCompiler.GetShownMsgTypes: TMessageTypes; +begin + Result:=[mtFatal]; + if coShowErrors in FOptions then Include(Result,mtError); + if coShowWarnings in FOptions then Include(Result,mtWarning); + if coShowNotes in FOptions then Include(Result,mtNote); + if coShowHints in FOptions then Include(Result,mtHint); + if coShowInfos in FOptions then Include(Result,mtInfo); + if coShowDebug in FOptions then Include(Result,mtDebug); +end; + +procedure TPas2jsCompiler.SetOption(Flag: TP2jsCompilerOption; Enable: boolean); +begin + if Enable then + Options:=Options+[Flag] + else + Options:=Options-[Flag]; +end; + +function TPas2jsCompiler.FindPasFile(PasFilename: string): TPas2jsCompilerFile; +var + Node: TAVLTreeNode; +begin + Result:=nil; + if PasFilename='' then exit; + Node:=FFiles.FindKey(Pointer(PasFilename),@CompareFileAndCompilerFilePasFile); + if Node=nil then exit; + Result:=TPas2jsCompilerFile(Node.Data); +end; + +procedure TPas2jsCompiler.LoadPasFile(PasFilename, UseUnitName: string; out + aFile: TPas2jsCompilerFile); +var + aPasTree: TPas2jsCompilerResolver; +begin + aFile:=nil; + Log.LogMsg(nParsingFile,[FileCache.FormatPath(PasFilename)],'',0,0,not (coShowLineNumbers in Options)); + + aFile:=FindPasFile(PasFilename); + if aFile<>nil then exit; + + if (PasFilename='') or not FileExists(PasFilename) then begin + Log.LogMsg(nSourceFileNotFound,[PasFilename]); + Terminate(ExitCodeFileNotFound); + end; + + PasFilename:=ExpandFileNameUTF8(PasFilename); + if DirectoryExists(PasFilename) then begin + Log.LogMsg(nFileIsFolder,[PasFilename]); + Terminate(ExitCodeFileNotFound); + end; + + aFile:=TPas2jsCompilerFile.Create(Self,PasFilename); + if UseUnitName<>'' then + begin + {$IFDEF VerboseSetPasUnitName} + writeln('TPas2jsCompiler.LoadPasFile File="',PasFilename,'" UseUnit="',UseUnitName,'"'); + {$ENDIF} + aFile.PasUnitName:=UseUnitName; + end; + FFiles.Add(aFile); + aFile.ShowDebug:=ShowDebug; + if aFile.IsMainFile then + aFile.JSFilename:=FileCache.GetResolvedMainJSFile; + + // pastree (engine) + aPasTree:=aFile.PascalResolver; + if coShowLineNumbers in Options then + aPasTree.ScannerLogEvents:=aPasTree.ScannerLogEvents+[sleLineNumber]; + if coShowConditionals in Options then + aPasTree.ScannerLogEvents:=aPasTree.ScannerLogEvents+[sleConditionals]; + if [coShowLineNumbers,coShowInfos,coShowDebug]*Options<>[] then + aPasTree.ParserLogEvents:=aPasTree.ParserLogEvents+[pleInterface,pleImplementation]; + + // scanner + aFile.CreateScannerAndParser(FileCache.CreateResolver); + + if ShowDebug then + Log.LogRaw(['Debug: Opening file "',PasFilename,'"...']); + // open file (beware: this changes aPasTree.FileResolver.BaseDirectory) + aFile.OpenFile(PasFilename); +end; + +function TPas2jsCompiler.FindUsedUnit(const TheUnitName: string + ): TPas2jsCompilerFile; +var + Node: TAVLTreeNode; +begin + if not IsValidIdent(TheUnitName,true) then exit(nil); + Node:=FUnits.FindKey(Pointer(TheUnitName),@CompareUnitnameAndCompilerFile); + if Node=nil then + Result:=nil + else + Result:=TPas2jsCompilerFile(Node.Data); +end; + +procedure TPas2jsCompiler.AddUsedUnit(aFile: TPas2jsCompilerFile); +var + OldFile: TPas2jsCompilerFile; +begin + if aFile.PasUnitName='' then + RaiseInternalError(20170504161347,'missing PasUnitName "'+aFile.PasFilename+'"'); + OldFile:=FindUsedUnit(aFile.PasUnitName); + if OldFile<>nil then begin + if OldFile<>aFile then + RaiseInternalError(20170504161354,'duplicate unit "'+OldFile.PasUnitName+'" "'+aFile.PasFilename+'" "'+OldFile.PasFilename+'"'); + end else begin + FUnits.Add(aFile); + end; +end; + +end. + diff --git a/utils/pas2js/pas2jsfilecache.pp b/utils/pas2js/pas2jsfilecache.pp new file mode 100644 index 0000000000..1b1588f3ed --- /dev/null +++ b/utils/pas2js/pas2jsfilecache.pp @@ -0,0 +1,1097 @@ +{ Author: Mattias Gaertner 2017 mattias@freepascal.org + + Abstract: + TPas2jsFileResolver extends TFileResolver and searches source files. +} +unit Pas2jsFileCache; + +{$mode objfpc}{$H+} + +{$i pas2js_defines.inc} + +interface + +uses + Classes, SysUtils, AVL_Tree, + PScanner, PasResolver, FPPJsSrcMap, + Pas2jsLogger, Pas2jsFileUtils; + +const // Messages + nIncludeSearch = 201; sIncludeSearch = 'Include file search: %s'; + nUnitSearch = 202; sUnitSearch = 'Unitsearch: %s'; + nSearchingFileFound = 203; sSearchingFileFound = 'Searching file: %s... found'; + nSearchingFileNotFound = 204; sSearchingFileNotFound = 'Searching file: %s... not found'; + +type + EPas2jsFileCache = class(Exception); + +type + TP2jsFileCacheOption = ( + caoShowFullFilenames, + caoShowTriedUsedFiles, + caoAllJSIntoMainJS + ); + TP2jsFileCacheOptions = set of TP2jsFileCacheOption; +const + DefaultPas2jsFileCacheOptions = []; + p2jsfcoCaption: array[TP2jsFileCacheOption] of string = ( + // only used by experts, no need for resourcestrings + 'Show full filenames', + 'Show tried/used files', + 'Combine all JavaScript into main file' + ); + +type + TPas2jsFilesCache = class; + TPas2jsCachedFile = class; + + { TPas2jsFileResolver } + + TPas2jsFileResolver = class(TFileResolver) + private + FCache: TPas2jsFilesCache; + public + constructor Create(aCache: TPas2jsFilesCache); reintroduce; + function FindIncludeFile(const aFilename: string): TLineReader; override; + function FindIncludeFileName(const aFilename: string): String; reintroduce; + function FindSourceFile(const aFilename: string): TLineReader; override; + function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; + function FindUnitJSFileName(const aUnitFilename: string): String; + function FindCustomJSFileName(const aFilename: string): String; + function FileExistsLogged(const Filename: string): boolean; + function SearchLowUpCase(var Filename: string): boolean; virtual; + property Cache: TPas2jsFilesCache read FCache; + end; + + { TPas2jsFileLineReader } + + TPas2jsFileLineReader = class(TLineReader) + private + FCachedFile: TPas2jsCachedFile; + FIsEOF: boolean; + FLineNumber: integer; + FSource: string; + FSrcPos: PChar; + public + constructor Create(const AFilename: string); override; + constructor Create(aFile: TPas2jsCachedFile); reintroduce; + function IsEOF: Boolean; override; + function ReadLine: string; override; + property LineNumber: integer read FLineNumber; + property CachedFile: TPas2jsCachedFile read FCachedFile; + property Source: string read FSource; + property SrcPos: PChar read FSrcPos; + end; + + { TPas2jsCachedFile } + + TPas2jsCachedFile = class + private + FCache: TPas2jsFilesCache; + FChangeStamp: TChangeStamp; + FFileEncoding: string; + FFilename: string; + FLastErrorMsg: string; + FLoaded: boolean; + FLoadedFileAge: longint; + FSource: string; + FCacheStamp: TChangeStamp; // Cache.ResetStamp when file was loaded + public + constructor Create(aCache: TPas2jsFilesCache; const aFilename: string); reintroduce; + function Load(RaiseOnError: boolean): boolean; + function CreateLineReader(RaiseOnError: boolean): TPas2jsFileLineReader; + property FileEncoding: string read FFileEncoding; + property Filename: string read FFilename; + property Source: string read FSource; // UTF-8 without BOM + property Cache: TPas2jsFilesCache read FCache; + property ChangeStamp: TChangeStamp read FChangeStamp;// changed when Source changed + property Loaded: boolean read FLoaded; // Source valid, but may contain an old version + property LastErrorMsg: string read FLastErrorMsg; + property LoadedFileAge: longint read FLoadedFileAge;// only valid if Loaded=true + end; + + TPas2jsCachedFilesState = ( + cfsMainJSFileResolved + ); + TPas2jsFileCacheStates = set of TPas2jsCachedFilesState; + + TPas2jsSearchPathKind = ( + spkPath, // e.g. unitpaths, includepaths + spkIdentifier // e.g. namespaces, trailing - means remove + ); + + { TPas2jsFilesCache } + + TPas2jsFilesCache = class + private + FBaseDirectory: string; + FFiles: TAVLTree; // tree of TPas2jsCachedFile sorted for Filename + FForeignUnitPaths: TStringList; + FForeignUnitPathsFromCmdLine: integer; + FIncludePaths: TStringList; + FIncludePathsFromCmdLine: integer; + FInsertFilenames: TStringList; + FLog: TPas2jsLogger; + FMainJSFile: string; + FMainJSFileResolved: string; // only valid if cfsMainJSFileResolved in FStates + FMainSrcFile: string; + FNamespaces: TStringList; + FNamespacesFromCmdLine: integer; + FOptions: TP2jsFileCacheOptions; + FReadLineCounter: SizeInt; + FResetStamp: TChangeStamp; + FSrcMapBaseDir: string; + FStates: TPas2jsFileCacheStates; + FUnitOutputPath: string; + FUnitPaths: TStringList; + FUnitPathsFromCmdLine: integer; + function GetAllJSIntoMainJS: Boolean; + function GetShowFullFilenames: boolean; + function GetShowTriedUsedFiles: boolean; + procedure RegisterMessages; + procedure SetAllJSIntoMainJS(AValue: Boolean); + procedure SetBaseDirectory(AValue: string); + function AddSearchPaths(const Paths: string; Kind: TPas2jsSearchPathKind; + FromCmdLine: boolean; var List: TStringList; var CmdLineCount: integer): string; + procedure SetMainJSFile(AValue: string); + procedure SetOptions(AValue: TP2jsFileCacheOptions); + procedure SetShowFullFilenames(AValue: boolean); + procedure SetShowTriedUsedFiles(AValue: boolean); + procedure SetSrcMapBaseDir(const AValue: string); + procedure SetUnitOutputPath(AValue: string); + procedure SetOption(Flag: TP2jsFileCacheOption; Enable: boolean); + public + constructor Create(aLog: TPas2jsLogger); + destructor Destroy; override; + procedure Reset; + function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean; + function AddNamespaces(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean; + function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean; + function AddSrcUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean; + function CreateResolver: TPas2jsFileResolver; + function FormatPath(const aPath: string): string; + function GetResolvedMainJSFile: string; + function LoadTextFile(Filename: string): TPas2jsCachedFile; + function NormalizeFilename(const Filename: string; RaiseOnError: boolean): string; + procedure InsertCustomJSFiles(aWriter: TPas2JSMapper); + function IndexOfInsertFilename(const aFilename: string): integer; + procedure AddInsertFilename(const aFilename: string); + procedure RemoveInsertFilename(const aFilename: string); + public + property AllJSIntoMainJS: Boolean read GetAllJSIntoMainJS write SetAllJSIntoMainJS; + property BaseDirectory: string read FBaseDirectory write SetBaseDirectory; // includes trailing pathdelim + property ForeignUnitPaths: TStringList read FForeignUnitPaths; + property ForeignUnitPathsFromCmdLine: integer read FForeignUnitPathsFromCmdLine; + property IncludePaths: TStringList read FIncludePaths; + property IncludePathsFromCmdLine: integer read FIncludePathsFromCmdLine; + property InsertFilenames: TStringList read FInsertFilenames; + property Log: TPas2jsLogger read FLog; + property MainJSFile: string read FMainJSFile write SetMainJSFile; + property MainSrcFile: string read FMainSrcFile write FMainSrcFile; + property Namespaces: TStringList read FNamespaces; + property NamespacesFromCmdLine: integer read FNamespacesFromCmdLine; + property Options: TP2jsFileCacheOptions read FOptions write SetOptions default DefaultPas2jsFileCacheOptions; + property ReadLineCounter: SizeInt read FReadLineCounter write FReadLineCounter; + property ResetStamp: TChangeStamp read FResetStamp; + property SrcMapBaseDir: string read FSrcMapBaseDir write SetSrcMapBaseDir; // includes trailing pathdelim + property ShowFullPaths: boolean read GetShowFullFilenames write SetShowFullFilenames; + property ShowTriedUsedFiles: boolean read GetShowTriedUsedFiles write SetShowTriedUsedFiles; + property UnitOutputPath: string read FUnitOutputPath write SetUnitOutputPath; // includes trailing pathdelim + property UnitPaths: TStringList read FUnitPaths; + property UnitPathsFromCmdLine: integer read FUnitPathsFromCmdLine; + end; + +function CompareFilenameWithCachedFile(Filename, CachedFile: Pointer): integer; +function CompareCachedFiles(File1, File2: Pointer): integer; +function ConvertTextToUTF8(const Src: string; var SrcEncoding: string): string; +function GuessEncoding(const Src: string): string; +function HasUTF8BOM(const s: string): boolean; +function RemoveUTFBOM(const s: string): string; + +implementation + +function CompareFilenameWithCachedFile(Filename, CachedFile: Pointer): integer; +var + Cache: TPas2jsCachedFile absolute CachedFile; +begin + Result:=CompareFilenames(AnsiString(Filename),Cache.Filename); +end; + +function CompareCachedFiles(File1, File2: Pointer): integer; +var + Cache1: TPas2jsCachedFile absolute File1; + Cache2: TPas2jsCachedFile absolute File2; +begin + Result:=CompareFilenames(Cache1.Filename,Cache2.Filename); +end; + +function ConvertTextToUTF8(const Src: string; var SrcEncoding: string): string; +var + p: PChar; + NormSrcEncoding: String; +begin + Result:=Src; + if SrcEncoding='' then + SrcEncoding:=GuessEncoding(Src); + if Result='' then exit; + NormSrcEncoding:=NormalizeEncoding(SrcEncoding); + if NormSrcEncoding=NormalizeEncoding(EncodingUTF8) then begin + p:=PChar(Result); + if (p^=#$EF) and (p[1]=#$BB) and (p[2]=#$BF) then begin + // cut out UTF-8 BOM + Delete(Result,1,3); + end; + end else if (NormSrcEncoding=EncodingSystem) + or (NormSrcEncoding=GetDefaultTextEncoding) then begin + Result:=SystemCPToUTF8(Result); + end else + EPas2jsFileCache.Create('invalid encoding "'+SrcEncoding+'"'); +end; + +function GuessEncoding(const Src: string): string; +var + p: PChar; + l: SizeInt; + i: Integer; +begin + if Src='' then exit(EncodingUTF8); + + if HasUTF8BOM(Src) then + // UTF-8 BOM + exit(EncodingUTF8); + + // try UTF-8 (this includes ASCII) + l:=length(Src); + p:=PChar(Src); + repeat + if ord(p^)<128 then begin + // ASCII + if (p^=#0) and (p-PChar(Src)>=l) then + exit(EncodingUTF8); + inc(p); + end else begin + i:=UTF8CharacterStrictLength(p); + if i=0 then + break; + inc(p,i); + end; + until false; + + // use system encoding + Result:=GetDefaultTextEncoding; +end; + +function HasUTF8BOM(const s: string): boolean; +var + p: PChar; +begin + if s='' then exit(false); + p:=PChar(s); + Result:=(p^=#$EF) and (p[1]=#$BB) and (p[2]=#$BF); +end; + +function RemoveUTFBOM(const s: string): string; +begin + Result:=s; + if not HasUTF8BOM(Result) then exit; + Delete(Result,1,3); +end; + +{ TPas2jsFileLineReader } + +constructor TPas2jsFileLineReader.Create(const AFilename: string); +var + ms: TMemoryStream; + NewSource, FileEncoding: string; +begin + inherited Create(AFilename); + ms:=TMemoryStream.Create; + try + try + ms.LoadFromFile(Filename); + SetLength(NewSource,ms.Size); + ms.Position:=0; + if NewSource<>'' then + ms.Read(NewSource[1],length(NewSource)); + except + on E: Exception do begin + EPas2jsFileCache.Create('Error reading file "'+Filename+'": '+E.Message); + exit; + end; + end; + finally + ms.Free; + end; + FileEncoding:=''; + FSource:=ConvertTextToUTF8(NewSource,FileEncoding); + FSrcPos:=PChar(FSource); + FIsEOF:=FSource=''; +end; + +constructor TPas2jsFileLineReader.Create(aFile: TPas2jsCachedFile); +begin + inherited Create(aFile.Filename); + FCachedFile:=aFile; + FSource:=aFile.Source; + FSrcPos:=PChar(FSource); + FIsEOF:=FSource=''; +end; + +function TPas2jsFileLineReader.IsEOF: Boolean; +begin + Result:=FIsEOF; +end; + +function TPas2jsFileLineReader.ReadLine: string; +var + p: PChar; + + procedure GetLine; + var + l: SizeInt; + begin + l:=p-FSrcPos; + SetLength(Result,l); + if l>0 then + Move(FSrcPos^,Result[1],l); + FSrcPos:=p; + inc(FLineNumber); + if (CachedFile<>nil) and (CachedFile.Cache<>nil) then + inc(CachedFile.Cache.FReadLineCounter); + //writeln('GetLine "',Result,'"'); + end; + +var + c: Char; +begin + if FIsEOF then exit(''); + p:=FSrcPos; + repeat + c:=p^; + case c of + #0: + if p-PChar(FSource)=length(FSource) then begin + FIsEOF:=true; + GetLine; + exit; + end; + #10,#13: + begin + GetLine; + inc(p); + if (p^ in [#10,#13]) and (p^<>c) then inc(p); + if (p^=#0) and (p-PChar(FSource)=length(FSource)) then + FIsEOF:=true; + FSrcPos:=p; + exit; + end; + end; + inc(p); + until false; + Result:=''; +end; + +{ TPas2jsCachedFile } + +constructor TPas2jsCachedFile.Create(aCache: TPas2jsFilesCache; + const aFilename: string); +begin + FChangeStamp:=InvalidChangeStamp; + FCache:=aCache; + FCacheStamp:=Cache.ResetStamp; + FFilename:=aFilename; +end; + +function TPas2jsCachedFile.Load(RaiseOnError: boolean): boolean; + + procedure Err(const ErrorMsg: string); + begin + FLastErrorMsg:=ErrorMsg; + if RaiseOnError then + raise EPas2jsFileCache.Create(FLastErrorMsg); + end; + +var + ms: TMemoryStream; + NewSource: string; +begin + {$IFDEF VerboseFileCache} + writeln('TPas2jsCachedFile.Load START "',Filename,'" Loaded=',Loaded); + {$ENDIF} + if Loaded then begin + // already loaded, check if it still valid + if (Cache.ResetStamp=FCacheStamp) then begin + // nothing changed + Result:=FLastErrorMsg=''; + if (not Result) and RaiseOnError then + raise EPas2jsFileCache.Create(FLastErrorMsg); + exit; + end; + {$IFDEF VerboseFileCache} + writeln('TPas2jsCachedFile.Load CHECK FILEAGE "',Filename,'"'); + {$ENDIF} + if LoadedFileAge=FileAge(Filename) then + exit(true); + end; + {$IFDEF VerboseFileCache} + writeln('TPas2jsCachedFile.Load RELOAD ',Filename,' Loaded=',Loaded); + {$ENDIF} + // needs (re)load + Result:=false; + if not FileExists(Filename) then begin + Err('File not found "'+Filename+'"'); + exit; + end; + if DirectoryExists(Filename) then begin + Err('File is a directory "'+Filename+'"'); + exit; + end; + ms:=TMemoryStream.Create; + try + try + ms.LoadFromFile(Filename); + SetLength(NewSource,ms.Size); + ms.Position:=0; + if NewSource<>'' then + ms.Read(NewSource[1],length(NewSource)); + except + on E: Exception do begin + Err('Error reading file "'+Filename+'": '+E.Message); + exit; + end; + end; + finally + ms.Free; + end; + {$IFDEF VerboseFileCache} + writeln('TPas2jsCachedFile.Load ENCODE ',Filename,' FFileEncoding=',FFileEncoding); + {$ENDIF} + FSource:=ConvertTextToUTF8(NewSource,FFileEncoding); + FLoaded:=true; + FCacheStamp:=Cache.ResetStamp; + FLoadedFileAge:=FileAge(Filename); + {$IFDEF VerboseFileCache} + writeln('TPas2jsCachedFile.Load END ',Filename,' FFileEncoding=',FFileEncoding); + {$ENDIF} +end; + +function TPas2jsCachedFile.CreateLineReader(RaiseOnError: boolean + ): TPas2jsFileLineReader; +begin + if not Load(RaiseOnError) then + exit(nil); + Result:=TPas2jsFileLineReader.Create(Self); +end; + +{ TPas2jsFileResolver } + +constructor TPas2jsFileResolver.Create(aCache: TPas2jsFilesCache); +begin + inherited Create; + FCache:=aCache; +end; + +function TPas2jsFileResolver.FindIncludeFile(const aFilename: string): TLineReader; +var + Filename: String; +begin + Result:=nil; + Filename:=FindIncludeFileName(aFilename); + if Filename='' then exit; + try + Result := TFileLineReader.Create(Filename); // ToDo: 1. convert encoding to UTF-8, 2. use cache + except + // error is shown in the scanner, which has the context information + end; +end; + +function TPas2jsFileResolver.FindIncludeFileName(const aFilename: string): String; + + function SearchCasedInIncPath(const Filename: string): string; + var + i: Integer; + begin + // file name is relative + // first search in the same directory as the unit + if BaseDirectory<>'' then + begin + Result:=BaseDirectory+Filename; + if SearchLowUpCase(Result) then exit; + end; + // then search in include path + for i:=0 to IncludePaths.Count-1 do begin + Result:=IncludePaths[i]+Filename; + if SearchLowUpCase(Result) then exit; + end; + Result:=''; + end; + +var + Filename : string; +begin + Result := ''; + + // convert pathdelims to system + Filename:=SetDirSeparators(aFilename); + if Cache.ShowTriedUsedFiles then + Cache.Log.LogMsgIgnoreFilter(nIncludeSearch,[Filename]); + + if FilenameIsAbsolute(Filename) then begin + Result:=Filename; + if not SearchLowUpCase(Result) then + Result:=''; + exit; + end; + + // search with the given file extension (even if no ext) + Result:=SearchCasedInIncPath(Filename); + if Result<>'' then exit; + + if ExtractFileExt(Filename)='' then begin + // search with the default file extensions + Result:=SearchCasedInIncPath(Filename+'.inc'); + if Result<>'' then exit; + Result:=SearchCasedInIncPath(Filename+'.pp'); + if Result<>'' then exit; + Result:=SearchCasedInIncPath(Filename+'.pas'); + if Result<>'' then exit; + end; +end; + +function TPas2jsFileResolver.FindSourceFile(const aFilename: string): TLineReader; +begin + Result:=nil; + if not FileExists(aFilename) then + raise EFileNotFoundError.Create(aFilename) + else + Result:=Cache.LoadTextFile(aFilename).CreateLineReader(false); +end; + +function TPas2jsFileResolver.FindUnitFileName(const aUnitname, + InFilename: string; out IsForeign: boolean): String; + + function SearchInDir(Dir: string; var Filename: string): boolean; + // search in Dir for pp, pas, p times given case, lower case, upper case + begin + Filename:=Dir+aUnitname+'.pp'; + if SearchLowUpCase(Filename) then exit(true); + Filename:=Dir+aUnitname+'.pas'; + if SearchLowUpCase(Filename) then exit(true); + Filename:=Dir+aUnitname+'.p'; + if SearchLowUpCase(Filename) then exit(true); + Result:=false; + end; + +var + i: Integer; +begin + Result:=''; + + if InFilename<>'' then begin + Cache.Log.LogMsgIgnoreFilter(nSearchingFileNotFound,['not yet implemented "in" '+Cache.FormatPath(InFilename)]) + // ToDo + end; + + // first search in foreign unit paths + IsForeign:=true; + for i:=0 to Cache.ForeignUnitPaths.Count-1 do + if SearchInDir(Cache.ForeignUnitPaths[i],Result) then begin + IsForeign:=true; + exit; + end; + + // then in BaseDirectory + IsForeign:=false; + if SearchInDir(BaseDirectory,Result) then exit; + + // finally search in unit paths + for i:=0 to Cache.UnitPaths.Count-1 do + if SearchInDir(Cache.UnitPaths[i],Result) then exit; + + Result:=''; +end; + +function TPas2jsFileResolver.FindUnitJSFileName(const aUnitFilename: string + ): String; +begin + Result:=''; + if aUnitFilename='' then exit; + if Cache.AllJSIntoMainJS then begin + Result:=Cache.GetResolvedMainJSFile; + end else begin + if Cache.UnitOutputPath<>'' then + Result:=Cache.UnitOutputPath+ChangeFileExt(ExtractFileName(aUnitFilename),'.js') + else + Result:=ChangeFileExt(aUnitFilename,'.js'); + end; +end; + +function TPas2jsFileResolver.FindCustomJSFileName(const aFilename: string + ): String; + + function SearchInDir(const Dir: string): boolean; + var + CurFilename: String; + begin + CurFilename:=Dir+aFilename; + Result:=FileExistsLogged(CurFilename); + if Result then + FindCustomJSFileName:=CurFilename; + end; + +var + i: Integer; +begin + Result:=''; + + if FilenameIsAbsolute(aFilename) then + begin + Result:=aFilename; + if not FileExistsLogged(Result) then + Result:=''; + exit; + end; + + if ExtractFilePath(aFilename)<>'' then + begin + Result:=ExpandFileNameUTF8(aFilename,BaseDirectory); + if not FileExistsLogged(Result) then + Result:=''; + exit; + end; + + // first search in foreign unit paths + for i:=0 to Cache.ForeignUnitPaths.Count-1 do + if SearchInDir(Cache.ForeignUnitPaths[i]) then + exit; + + // then in BaseDirectory + if SearchInDir(BaseDirectory) then exit; + + // finally search in unit paths + for i:=0 to Cache.UnitPaths.Count-1 do + if SearchInDir(Cache.UnitPaths[i]) then exit; + + Result:=''; +end; + +function TPas2jsFileResolver.FileExistsLogged(const Filename: string): boolean; +begin + Result:=FileExists(Filename); + if Cache.ShowTriedUsedFiles then + if Result then + Cache.Log.LogMsgIgnoreFilter(nSearchingFileFound,[Cache.FormatPath(Filename)]) + else + Cache.Log.LogMsgIgnoreFilter(nSearchingFileNotFound,[Cache.FormatPath(Filename)]); +end; + +function TPas2jsFileResolver.SearchLowUpCase(var Filename: string): boolean; +{$IFNDEF CaseInsensitiveFilenames} +var + CasedFilename: String; +{$ENDIF} +begin + if FileExistsLogged(Filename) then + exit(true); + if StrictFileCase then + exit(false); + {$IFNDEF CaseInsensitiveFilenames} + CasedFilename:=ExtractFilePath(Filename)+LowerCase(ExtractFileName(Filename)); + if (Filename<>CasedFilename) and FileExistsLogged(CasedFilename) then begin + Filename:=CasedFilename; + exit(true); + end; + CasedFilename:=ExtractFilePath(Filename)+UpperCase(ExtractFileName(Filename)); + if (Filename<>CasedFilename) and FileExistsLogged(CasedFilename) then begin + Filename:=CasedFilename; + exit(true); + end; + {$ENDIF} + Result:=false; +end; + +{ TPas2jsFilesCache } + +procedure TPas2jsFilesCache.RegisterMessages; +begin + Log.RegisterMsg(mtInfo,nIncludeSearch,sIncludeSearch); + Log.RegisterMsg(mtInfo,nUnitSearch,sUnitSearch); + Log.RegisterMsg(mtInfo,nSearchingFileFound,sSearchingFileFound); + Log.RegisterMsg(mtInfo,nSearchingFileNotFound,sSearchingFileNotFound); +end; + +function TPas2jsFilesCache.GetAllJSIntoMainJS: Boolean; +begin + Result:=caoAllJSIntoMainJS in FOptions; +end; + +function TPas2jsFilesCache.GetShowFullFilenames: boolean; +begin + Result:=caoShowFullFilenames in FOptions; +end; + +function TPas2jsFilesCache.GetShowTriedUsedFiles: boolean; +begin + Result:=caoShowTriedUsedFiles in FOptions; +end; + +procedure TPas2jsFilesCache.SetAllJSIntoMainJS(AValue: Boolean); +begin + SetOption(caoAllJSIntoMainJS,AValue); +end; + +procedure TPas2jsFilesCache.SetBaseDirectory(AValue: string); +begin + AValue:=ExpandDirectory(AValue); + if FBaseDirectory=AValue then Exit; + FBaseDirectory:=AValue; +end; + +function TPas2jsFilesCache.AddSearchPaths(const Paths: string; + Kind: TPas2jsSearchPathKind; FromCmdLine: boolean; var List: TStringList; + var CmdLineCount: integer): string; +// cmd line paths are added in front of the cfg paths +// cmd line paths are added in order, cfg paths are added in reverse order +// multi paths separated by semicolon are added in order +// duplicates are removed +var + Added: Integer; + + function Add(aPath: string): boolean; + var + Remove: Boolean; + i: Integer; + begin + Remove:=false; + // search duplicate + case Kind of + spkPath: + begin + i:=List.Count-1; + while (i>=0) and (CompareFilenames(aPath,List[i])<>0) do dec(i); + end; + spkIdentifier: + begin + if aPath[length(aPath)]='-' then begin + Delete(aPath,length(aPath),1); + Remove:=true; + end; + if not IsValidIdent(aPath,true,true) then + begin + AddSearchPaths:=aPath; + exit(false); + end; + i:=List.Count-1; + while (i>=0) and (CompareText(aPath,List[i])<>0) do dec(i); + end; + end; + + if Remove then begin + // remove + if i>=0 then begin + List.Delete(i); + if CmdLineCount>i then dec(CmdLineCount); + end; + exit(true); + end; + + if FromCmdLine then begin + // from cmdline: append in order to the cmdline params, in front of cfg params + if i>=0 then begin + if i<=CmdLineCount then exit(true); + List.Delete(i); + end; + List.Insert(CmdLineCount,aPath); + inc(CmdLineCount); + end else begin + // from cfg: append in reverse order to the cfg params, behind cmdline params + if i>=0 then begin + if i<=CmdLineCount+Added then exit(true); + List.Delete(i); + end; + List.Insert(CmdLineCount+Added,aPath); + inc(Added); + end; + Result:=true; + end; + +var + aPath: String; + p, i: integer; + aPaths: TStringList; +begin + Result:=''; + p:=1; + Added:=0; + aPaths:=TStringList.Create; + try + while p<=length(Paths) do begin + aPath:=GetNextDelimitedItem(Paths,';',p); + if aPath='' then continue; + if Kind=spkPath then + aPath:=ExpandDirectory(aPath); + if (aPath='') then continue; + aPaths.Clear; + FindMatchingFiles(aPath,1000,aPaths); + if aPaths.Count=0 then begin + if not Add(aPath) then exit; + end else begin + for i:=0 to aPaths.Count-1 do + if not Add(aPaths[i]) then exit; + end; + end; + finally + aPaths.Free; + end; +end; + +procedure TPas2jsFilesCache.SetMainJSFile(AValue: string); +begin + if FMainJSFile=AValue then Exit; + FMainJSFile:=AValue; +end; + +procedure TPas2jsFilesCache.SetOptions(AValue: TP2jsFileCacheOptions); +begin + if FOptions=AValue then Exit; + FOptions:=AValue; +end; + +procedure TPas2jsFilesCache.SetShowFullFilenames(AValue: boolean); +begin + SetOption(caoShowFullFilenames,AValue); +end; + +procedure TPas2jsFilesCache.SetShowTriedUsedFiles(AValue: boolean); +begin + SetOption(caoShowTriedUsedFiles,AValue); +end; + +procedure TPas2jsFilesCache.SetSrcMapBaseDir(const AValue: string); +var + NewValue: String; +begin + NewValue:=ExpandDirectory(AValue); + if FSrcMapBaseDir=NewValue then Exit; + FSrcMapBaseDir:=NewValue; +end; + +procedure TPas2jsFilesCache.SetUnitOutputPath(AValue: string); +begin + AValue:=ExpandDirectory(AValue); + if FUnitOutputPath=AValue then Exit; + FUnitOutputPath:=AValue; +end; + +procedure TPas2jsFilesCache.SetOption(Flag: TP2jsFileCacheOption; Enable: boolean + ); +begin + if Enable then + Include(FOptions,Flag) + else + Exclude(FOptions,Flag); + if Flag in [caoAllJSIntoMainJS] then + Exclude(FStates,cfsMainJSFileResolved); +end; + +constructor TPas2jsFilesCache.Create(aLog: TPas2jsLogger); +begin + inherited Create; + FResetStamp:=InvalidChangeStamp; + FLog:=aLog; + FOptions:=DefaultPas2jsFileCacheOptions; + FIncludePaths:=TStringList.Create; + FInsertFilenames:=TStringList.Create; + FForeignUnitPaths:=TStringList.Create; + FNamespaces:=TStringList.Create; + FUnitPaths:=TStringList.Create; + FFiles:=TAVLTree.Create(@CompareCachedFiles); + RegisterMessages; +end; + +destructor TPas2jsFilesCache.Destroy; +begin + FLog:=nil; + FFiles.FreeAndClear; + FreeAndNil(FFiles); + FreeAndNil(FInsertFilenames); + FreeAndNil(FIncludePaths); + FreeAndNil(FForeignUnitPaths); + FreeAndNil(FNamespaces); + FreeAndNil(FUnitPaths); + inherited Destroy; +end; + +procedure TPas2jsFilesCache.Reset; +begin + IncreaseChangeStamp(FResetStamp); + FOptions:=DefaultPas2jsFileCacheOptions; + FMainJSFile:=''; + FMainSrcFile:=''; + FBaseDirectory:=''; + FSrcMapBaseDir:=''; + FUnitOutputPath:=''; + FReadLineCounter:=0; + FForeignUnitPaths.Clear; + FUnitPaths.Clear; + FIncludePaths.Clear; + FStates:=FStates-[cfsMainJSFileResolved]; +end; + +function TPas2jsFilesCache.AddIncludePaths(const Paths: string; + FromCmdLine: boolean; out ErrorMsg: string): boolean; +begin + ErrorMsg:=AddSearchPaths(Paths,spkPath,FromCmdLine,FIncludePaths,FIncludePathsFromCmdLine); + Result:=ErrorMsg=''; +end; + +function TPas2jsFilesCache.AddNamespaces(const Paths: string; + FromCmdLine: boolean; out ErrorMsg: string): boolean; +begin + ErrorMsg:=AddSearchPaths(Paths,spkIdentifier,FromCmdLine,FNamespaces,FNamespacesFromCmdLine); + Result:=ErrorMsg=''; +end; + +function TPas2jsFilesCache.AddUnitPaths(const Paths: string; + FromCmdLine: boolean; out ErrorMsg: string): boolean; +begin + ErrorMsg:=AddSearchPaths(Paths,spkPath,FromCmdLine,FUnitPaths,FUnitPathsFromCmdLine); + Result:=ErrorMsg=''; +end; + +function TPas2jsFilesCache.AddSrcUnitPaths(const Paths: string; + FromCmdLine: boolean; out ErrorMsg: string): boolean; +begin + ErrorMsg:=AddSearchPaths(Paths,spkPath,FromCmdLine,FForeignUnitPaths,FForeignUnitPathsFromCmdLine); + Result:=ErrorMsg=''; +end; + +function TPas2jsFilesCache.CreateResolver: TPas2jsFileResolver; +begin + Result := TPas2jsFileResolver.Create(Self); + Result.UseStreams:=false; + Result.BaseDirectory:=BaseDirectory; // beware: will be changed by Scanner.OpenFile +end; + +function TPas2jsFilesCache.FormatPath(const aPath: string): string; +begin + Result:=aPath; + if (Result='') or (BaseDirectory='') then exit; + if FilenameIsAbsolute(aPath) then begin + if not ShowFullPaths then begin + if BaseDirectory=LeftStr(Result,length(BaseDirectory)) then + Delete(Result,1,length(BaseDirectory)); + end; + end else begin + if ShowFullPaths then + Result:=BaseDirectory+Result; + end; +end; + +function TPas2jsFilesCache.GetResolvedMainJSFile: string; +begin + if not (cfsMainJSFileResolved in FStates) then begin + if MainJSFile='.' then + FMainJSFileResolved:='' + else begin + FMainJSFileResolved:=MainJSFile; + if FMainJSFileResolved='' then begin + // no option -o + if UnitOutputPath<>'' then begin + // option -FU and no -o => put into UnitOutputPath + FMainJSFileResolved:=UnitOutputPath+ChangeFileExt(ExtractFilename(MainSrcFile),'.js') + end else begin + // no -FU and no -o => put into source directory + FMainJSFileResolved:=ChangeFileExt(MainSrcFile,'.js'); + end; + end else begin + // has option -o + if (ExtractFilePath(FMainJSFileResolved)='') and (UnitOutputPath<>'') then + FMainJSFileResolved:=UnitOutputPath+FMainJSFileResolved; + end; + end; + Include(FStates,cfsMainJSFileResolved); + end; + Result:=FMainJSFileResolved; +end; + +function TPas2jsFilesCache.LoadTextFile(Filename: string): TPas2jsCachedFile; +var + Node: TAVLTreeNode; +begin + Filename:=NormalizeFilename(Filename,true); + Node:=FFiles.FindKey(Pointer(Filename),@CompareFilenameWithCachedFile); + if Node=nil then begin + // new file + Result:=TPas2jsCachedFile.Create(Self,Filename); + FFiles.Add(Result); + end else begin + Result:=TPas2jsCachedFile(Node.Data); + end; + Result.Load(true); +end; + +function TPas2jsFilesCache.NormalizeFilename(const Filename: string; + RaiseOnError: boolean): string; +begin + Result:=Filename; + if ExtractFilename(Result)='' then + if RaiseOnError then + raise EFileNotFoundError.Create('invalid file name "'+Filename+'"'); + Result:=ExpandFileNameUTF8(Result); + if (ExtractFilename(Result)='') or not FilenameIsAbsolute(Result) then + if RaiseOnError then + raise EFileNotFoundError.Create('invalid file name "'+Filename+'"'); +end; + +procedure TPas2jsFilesCache.InsertCustomJSFiles(aWriter: TPas2JSMapper); +var + i: Integer; + Filename: String; + FileResolver: TPas2jsFileResolver; + aFile: TPas2jsCachedFile; +begin + if InsertFilenames.Count=0 then exit; + FileResolver:=CreateResolver; + try + for i:=0 to InsertFilenames.Count-1 do begin + Filename:=FileResolver.FindCustomJSFileName(ResolveDots(InsertFilenames[i])); + if Filename='' then + raise EFileNotFoundError.Create('invalid custom JS file name "'+InsertFilenames[i]+'"'); + aFile:=LoadTextFile(Filename); + if aFile.Source='' then continue; + aWriter.WriteFile(aFile.Source,Filename); + end + finally + FileResolver.Free; + end; +end; + +function TPas2jsFilesCache.IndexOfInsertFilename(const aFilename: string + ): integer; +var + i: Integer; +begin + for i:=0 to FInsertFilenames.Count-1 do + if CompareFilenames(aFilename,InsertFilenames[i])=0 then + exit(i); + Result:=-1; +end; + +procedure TPas2jsFilesCache.AddInsertFilename(const aFilename: string); +begin + if IndexOfInsertFilename(aFilename)<0 then + InsertFilenames.Add(aFilename); +end; + +procedure TPas2jsFilesCache.RemoveInsertFilename(const aFilename: string); +var + i: Integer; +begin + i:=IndexOfInsertFilename(aFilename); + if i>=0 then + InsertFilenames.Delete(i); +end; + +end. + diff --git a/utils/pas2js/pas2jsfileutils.pp b/utils/pas2js/pas2jsfileutils.pp new file mode 100644 index 0000000000..64fa0c0ab4 --- /dev/null +++ b/utils/pas2js/pas2jsfileutils.pp @@ -0,0 +1,676 @@ +{ Author: Mattias Gaertner 2017 mattias@freepascal.org + + Abstract: + Low level file path handling. +} +unit Pas2jsFileUtils; + +{$mode objfpc}{$H+} + +{$i pas2js_defines.inc} + +interface + +uses + {$IFDEF Unix} + BaseUnix, + {$ENDIF} + SysUtils, Classes; + +function FilenameIsAbsolute(const aFilename: string):boolean; +function FilenameIsWinAbsolute(const aFilename: string):boolean; +function FilenameIsUnixAbsolute(const aFilename: string):boolean; +function FileIsInPath(const Filename, Path: string): boolean; +function ChompPathDelim(const Path: string): string; +function ExpandFileNameUTF8(const FileName: string; {const} BaseDir: string = ''): string; +function ExpandDirectory(const aDirectory: string): string; +function TryCreateRelativePath(const Filename, BaseDirectory: String; + UsePointDirectory: boolean; out RelPath: String): Boolean; +function ResolveDots(const AFilename: string): string; +procedure ForcePathDelims(Var FileName: string); +function GetForcedPathDelims(Const FileName: string): String; +function ExtractFilenameOnly(const aFilename: string): string; +function GetCurrentDirUTF8: String; +function CompareFilenames(const File1, File2: string): integer; + +function GetPhysicalFilename(const Filename: string; + ExceptionOnError: boolean): string; +function ResolveSymLinks(const Filename: string; + {%H-}ExceptionOnError: boolean): string; // if a link is broken returns '' +procedure FindMatchingFiles(Mask: string; MaxCount: integer; Files: TStrings);// find files, matching * and ? + +function GetEnvironmentVariableCountUTF8: Integer; +function GetEnvironmentStringUTF8(Index: Integer): string; +function GetEnvironmentVariableUTF8(const EnvVar: string): String; + +function GetNextDelimitedItem(const List: string; Delimiter: char; + var Position: integer): string; + +type TChangeStamp = SizeInt; +const InvalidChangeStamp = low(TChangeStamp); +procedure IncreaseChangeStamp(var Stamp: TChangeStamp); + +const + UTF8BOM = #$EF#$BB#$BF; + EncodingUTF8 = 'UTF-8'; + EncodingSystem = 'System'; +function NormalizeEncoding(const Encoding: string): string; +function IsNonUTF8System: boolean;// true if system encoding is not UTF-8 +function UTF8CharacterStrictLength(P: PChar): integer; +function GetDefaultTextEncoding: string; +function GetConsoleTextEncoding: string; +{$IFDEF Windows} +// AConsole - If false, it is the general system encoding, +// if true, it is the console encoding +function GetWindowsEncoding(AConsole: Boolean = False): string; +{$ENDIF} +{$IF defined(Unix) and not defined(Darwin)} +function GetUnixEncoding: string; +{$ENDIF} +function IsASCII(const s: string): boolean; inline; + +function UTF8ToUTF16(const s: string): UnicodeString; +function UTF16ToUTF8(const s: UnicodeString): string; + +function UTF8ToSystemCP(const s: string): string; +function SystemCPToUTF8(const s: string): string; + +function ConsoleToUTF8(const s: string): string; +// converts UTF8 string to console encoding (used by Write, WriteLn) +function UTF8ToConsole(const s: string): string; + +implementation + +{$IFDEF Windows} +uses Windows; +{$ENDIF} + +var + EncodingValid: boolean = false; + DefaultTextEncoding: string = EncodingSystem; + {$IFDEF Unix} + {$IFNDEF Darwin} + Lang: string = ''; + {$ENDIF} + {$ENDIF} + NonUTF8System: boolean = false; + +function FilenameIsWinAbsolute(const aFilename: string): boolean; +begin + Result:=((length(aFilename)>=3) and + (aFilename[1] in ['A'..'Z','a'..'z']) and (aFilename[2]=':') and (aFilename[3]in AllowDirectorySeparators)) + or ((length(aFilename)>=2) and (aFilename[1] in AllowDirectorySeparators) and (aFilename[2] in AllowDirectorySeparators)); +end; + +function FilenameIsUnixAbsolute(const aFilename: string): boolean; +begin + Result:=(aFilename<>'') and (aFilename[1]='/'); +end; + +function FileIsInPath(const Filename, Path: string): boolean; +var + ExpFile: String; + ExpPath: String; + l: integer; +begin + if Path='' then begin + Result:=false; + exit; + end; + ExpFile:=Filename; + ExpPath:=IncludeTrailingPathDelimiter(Path); + l:=length(ExpPath); + Result:=(l>0) and (length(ExpFile)>l) and (ExpFile[l]=PathDelim) + and (AnsiCompareFileName(ExpPath,LeftStr(ExpFile,l))=0); +end; + +function ChompPathDelim(const Path: string): string; +var + Len, MinLen: Integer; +begin + Result:=Path; + if Path = '' then + exit; + Len:=length(Result); + if (Result[1] in AllowDirectorySeparators) then begin + MinLen := 1; + {$IFDEF HasUNCPaths} + if (Len >= 2) and (Result[2] in AllowDirectorySeparators) then + MinLen := 2; // keep UNC '\\', chomp 'a\' to 'a' + {$ENDIF} + end + else begin + MinLen := 0; + {$IFdef MSWindows} + if (Len >= 3) and (Result[1] in ['a'..'z', 'A'..'Z']) and + (Result[2] = ':') and (Result[3] in AllowDirectorySeparators) + then + MinLen := 3; + {$ENDIF} + end; + + while (Len > MinLen) and (Result[Len] in AllowDirectorySeparators) do dec(Len); + if Len<length(Result) then + SetLength(Result,Len); +end; + +function ExpandDirectory(const aDirectory: string): string; +begin + Result:=aDirectory; + if Result='' then exit; + Result:=ExpandFileNameUTF8(Result); + if Result='' then exit; + Result:=IncludeTrailingPathDelimiter(Result); +end; + +function TryCreateRelativePath(const Filename, BaseDirectory: String; + UsePointDirectory: boolean; out RelPath: String): Boolean; +{ + Returns True if it is possible to create a relative path from Source to Dest + Function must be thread safe, so no expanding of filenames is done, since this + is not threadsafe (at least on Windows platform) + + - Dest and Source must either be both absolute filenames, or relative + - Dest and Source cannot contain '..' since no expanding is done by design + - Dest and Source must be on same drive or UNC path (Windows) + - if both Dest and Source are relative they must at least share their base directory + - Double PathDelims are ignored (unless they are part of the UNC convention) + + - if UsePointDirectory is True and Result is True then if RelPath is Empty string, RelPath becomes '.' + - if AlwaysRequireSharedBaseFolder is False then Absolute filenames need not share a basefolder + + - if the function succeeds RelPath contains the relative path from Source to Dest, + no PathDelimiter is appended to the end of RelPath + + Examples: + - Filename = /foo/bar BaseDirectory = /foo Result = True RelPath = bar + - Filename = /foo///bar BaseDirectory = /foo// Result = True RelPath = bar + - Filename = /foo BaseDirectory = /foo/bar Result = True RelPath = ../ + - Filename = /foo/bar BaseDirectory = /bar Result = False (no shared base directory) + - Filename = foo/bar BaseDirectory = foo/foo Result = True RelPath = ../bar + - Filename = foo/bar BaseDirectory = bar/foo Result = False (no shared base directory) + - Filename = /foo BaseDirectory = bar Result = False (mixed absolute and relative) +} + + function IsNameChar(c: char): boolean; inline; + begin + Result:=(c<>#0) and not (c in AllowDirectorySeparators); + end; + +var + UpDirCount: Integer; + ResultPos: Integer; + i: Integer; + FileNameRestLen, SharedDirs: Integer; + FileP, BaseP, FileEndP, BaseEndP: PChar; +begin + Result:=false; + RelPath:=Filename; + if (BaseDirectory='') or (Filename='') then exit; + // check for different windows file drives + if (CompareText(ExtractFileDrive(Filename), + ExtractFileDrive(BaseDirectory))<>0) + then + exit; + + FileP:=PChar(Filename); + BaseP:=PChar(BaseDirectory); + + //writeln('TryCreateRelativePath START File="',FileP,'" Base="',BaseP,'"'); + + // skip matching directories + SharedDirs:=0; + if FileP^ in AllowDirectorySeparators then begin + if not (BaseP^ in AllowDirectorySeparators) then exit; + repeat + while FileP^ in AllowDirectorySeparators do inc(FileP); + while BaseP^ in AllowDirectorySeparators do inc(BaseP); + if (FileP^=#0) or (BaseP^=#0) then break; + //writeln('TryCreateRelativePath check match .. File="',FileP,'" Base="',BaseP,'"'); + FileEndP:=FileP; + BaseEndP:=BaseP; + while IsNameChar(FileEndP^) do inc(FileEndP); + while IsNameChar(BaseEndP^) do inc(BaseEndP); + if CompareFilenames(copy(Filename,FileP-PChar(Filename)+1,FileEndP-FileP), + copy(BaseDirectory,BaseP-PChar(BaseDirectory)+1,BaseEndP-BaseP))<>0 + then + break; + FileP:=FileEndP; + BaseP:=BaseEndP; + inc(SharedDirs); + until false; + end else if (BaseP^ in AllowDirectorySeparators) then + exit; + + //writeln('TryCreateRelativePath skipped matches File="',FileP,'" Base="',BaseP,'"'); + if SharedDirs=0 then exit; + + // calculate needed '../' + UpDirCount:=0; + BaseEndP:=BaseP; + while IsNameChar(BaseEndP^) do begin + inc(UpDirCount); + while IsNameChar(BaseEndP^) do inc(BaseEndP); + while BaseEndP^ in AllowDirectorySeparators do inc(BaseEndP); + end; + + //writeln('TryCreateRelativePath UpDirCount=',UpDirCount,' File="',FileP,'" Base="',BaseP,'"'); + // create relative filename + if (FileP^=#0) and (UpDirCount=0) then begin + // Filename is the BaseDirectory + if UsePointDirectory then + RelPath:='.' + else + RelPath:=''; + exit(true); + end; + + FileNameRestLen:=length(Filename)-(FileP-PChar(Filename)); + SetLength(RelPath,3*UpDirCount+FileNameRestLen); + ResultPos:=1; + for i:=1 to UpDirCount do begin + RelPath[ResultPos]:='.'; + RelPath[ResultPos+1]:='.'; + RelPath[ResultPos+2]:=PathDelim; + inc(ResultPos,3); + end; + if FileNameRestLen>0 then + Move(FileP^,RelPath[ResultPos],FileNameRestLen); + Result:=true; +end; + +function ResolveDots(const AFilename: string): string; +//trim double path delims and expand special dirs like .. and . +//on Windows change also '/' to '\' except for filenames starting with '\\?\' +var SrcPos, DestPos, l, DirStart: integer; + c: char; + MacroPos: LongInt; +begin + Result:=AFilename; + {$ifdef windows} + //Special case: everything is literal after this, even dots (this does not apply to '//?/') + if (Pos('\\?\', AFilename) = 1) then Exit; + {$endif} + + l:=length(AFilename); + SrcPos:=1; + DestPos:=1; + + + // trim double path delimiters and special dirs . and .. + while (SrcPos<=l) do begin + c:=AFilename[SrcPos]; + {$ifdef windows} + //change / to \. The WinApi accepts both, but it leads to strange effects in other places + if (c in AllowDirectorySeparators) then c := PathDelim; + {$endif} + // check for double path delims + if (c=PathDelim) then begin + inc(SrcPos); + {$IFDEF Windows} + if (DestPos>2) + {$ELSE} + if (DestPos>1) + {$ENDIF} + and (Result[DestPos-1]=PathDelim) then begin + // skip second PathDelim + continue; + end; + Result[DestPos]:=c; + inc(DestPos); + continue; + end; + // check for special dirs . and .. + if (c='.') then begin + if (SrcPos<l) then begin + if (AFilename[SrcPos+1]=PathDelim) + and ((DestPos=1) or (AFilename[SrcPos-1]=PathDelim)) then begin + // special dir ./ or */./ + // -> skip + inc(SrcPos,2); + continue; + end else if (AFilename[SrcPos+1]='.') + and (SrcPos+1=l) or (AFilename[SrcPos+2]=PathDelim) then + begin + // special dir .. + // 1. .. -> copy + // 2. /.. -> skip .., keep / + // 3. C:.. -> copy + // 4. C:\.. -> skip .., keep C:\ + // 5. \\.. -> skip .., keep \\ + // 6. ../.. -> copy because if the first '..' was not resolved, the next can't neither + // 7. dir/.. -> trim dir and .. + // 8. dir$macro/.. -> copy + if DestPos=1 then begin + // 1. .. or ../ -> copy + end else if (DestPos=2) and (Result[1]=PathDelim) then begin + // 2. /.. -> skip .., keep / + inc(SrcPos,2); + continue; + {$IFDEF Windows} + end else if (DestPos=3) and (Result[2]=':') + and (Result[1] in ['a'..'z','A'..'Z']) then begin + // 3. C:.. -> copy + end else if (DestPos=4) and (Result[2]=':') and (Result[3]=PathDelim) + and (Result[1] in ['a'..'z','A'..'Z']) then begin + // 4. C:\.. -> skip .., keep C:\ + inc(SrcPos,2); + continue; + end else if (DestPos=3) and (Result[1]=PathDelim) + and (Result[2]=PathDelim) then begin + // 5. \\.. -> skip .., keep \\ + inc(SrcPos,2); + continue; + {$ENDIF} + end else if (DestPos>1) and (Result[DestPos-1]=PathDelim) then begin + // */. + if (DestPos>3) + and (Result[DestPos-2]='.') and (Result[DestPos-3]='.') + and ((DestPos=4) or (Result[DestPos-4]=PathDelim)) then begin + // 6. ../.. -> copy because if the first '..' was not resolved, the next can't neither + end else begin + // 7. xxxdir/.. -> trim dir and skip .. + DirStart:=DestPos-2; + while (DirStart>1) and (Result[DirStart-1]<>PathDelim) do + dec(DirStart); + MacroPos:=DirStart; + while MacroPos<DestPos do begin + if (Result[MacroPos]='$') + and (Result[MacroPos+1] in ['(','a'..'z','A'..'Z']) then begin + // 8. directory contains a macro -> keep + break; + end; + inc(MacroPos); + end; + if MacroPos=DestPos then begin + // previous directory does not contain a macro -> remove dir/.. + DestPos:=DirStart; + inc(SrcPos,2); + //writeln('ResolveDots ',DestPos,' SrcPos=',SrcPos,' File="',AFilename,'" Result="',copy(Result,1,DestPos-1),'"'); + if SrcPos>l then begin + // '..' at end of filename + if (DestPos>1) and (Result[DestPos-1]<>PathDelim) then begin + // foo/dir/.. -> foo + dec(DestPos); + end else if (DestPos=1) then begin + // foo/.. -> . + Result[1]:='.'; + DestPos:=2; + end; + end else if DestPos=1 then begin + // e.g. 'foo/../' + while (SrcPos<=l) and (AFilename[SrcPos] in AllowDirectorySeparators) do + inc(SrcPos); + end; + continue; + end; + end; + end; + end; + end else begin + // special dir . at end of filename + if DestPos=1 then begin + Result:='.'; + exit; + end else begin + // skip + break; + end; + end; + end; + // copy directory + repeat + Result[DestPos]:=c; + inc(DestPos); + inc(SrcPos); + if (SrcPos>l) then break; + c:=AFilename[SrcPos]; + {$ifdef windows} + //change / to \. The WinApi accepts both, but it leads to strange effects in other places + if (c in AllowDirectorySeparators) then c := PathDelim; + {$endif} + if c=PathDelim then break; + until false; + end; + // trim result + if DestPos<=length(AFilename) then + SetLength(Result,DestPos-1); +end; + +procedure ForcePathDelims(Var FileName: string); +var + i: Integer; +begin + for i:=1 to length(FileName) do + {$IFDEF Windows} + if Filename[i]='/' then + Filename[i]:='\'; + {$ELSE} + if Filename[i]='\' then + Filename[i]:='/'; + {$ENDIF} +end; + +function GetForcedPathDelims(const FileName: string): String; +begin + Result:=FileName; + ForcePathDelims(Result); +end; + +function ExtractFilenameOnly(const aFilename: string): string; +var + StartPos: Integer; + ExtPos: Integer; +begin + StartPos:=length(AFilename)+1; + while (StartPos>1) + and not (AFilename[StartPos-1] in AllowDirectorySeparators) + {$IFDEF Windows}and (AFilename[StartPos-1]<>':'){$ENDIF} + do + dec(StartPos); + ExtPos:=length(AFilename); + while (ExtPos>=StartPos) and (AFilename[ExtPos]<>'.') do + dec(ExtPos); + if (ExtPos<StartPos) then ExtPos:=length(AFilename)+1; + Result:=copy(AFilename,StartPos,ExtPos-StartPos); +end; + +function CompareFilenames(const File1, File2: string): integer; +begin + Result:=AnsiCompareFileName(File1,File2); +end; + +procedure FindMatchingFiles(Mask: string; MaxCount: integer; Files: TStrings); +var + p: Integer; + Path, Filename: String; + Info: TRawByteSearchRec; +begin + Mask:=ResolveDots(Mask); + p:=1; + while p<=length(Mask) do begin + if Mask[p] in ['*','?'] then begin + while (p<=length(Mask)) and not (Mask[p] in AllowDirectorySeparators) do inc(p); + Path:=LeftStr(Mask,p-1); + if FindFirst(Path,faAnyFile,Info)=0 then begin + repeat + Filename:=ExtractFilePath(Path)+Info.Name; + if p>length(Mask) then begin + // e.g. /path/unit*.pas + if Files.Count>=MaxCount then + raise EListError.Create('found too many files "'+Path+'"'); + Files.Add(Filename); + end else begin + // e.g. /path/sub*path/... + FindMatchingFiles(Filename+copy(Mask,p,length(Mask)),MaxCount,Files); + end; + until FindNext(Info)<>0; + end; + exit; + end; + inc(p); + end; + if FileExists(Mask) then begin + if Files.Count>=MaxCount then + raise EListError.Create('found too many files "'+Mask+'"'); + Files.Add(Mask); + end; +end; + +function GetNextDelimitedItem(const List: string; Delimiter: char; + var Position: integer): string; +var + StartPos: Integer; +begin + StartPos:=Position; + while (Position<=length(List)) and (List[Position]<>Delimiter) do + inc(Position); + Result:=copy(List,StartPos,Position-StartPos); + if Position<=length(List) then inc(Position); // skip Delimiter +end; + +procedure IncreaseChangeStamp(var Stamp: TChangeStamp); +begin + if Stamp<High(TChangeStamp) then + inc(Stamp) + else + Stamp:=InvalidChangeStamp+1; +end; + +function IsNonUTF8System: boolean; +begin + Result:=NonUTF8System; +end; + +function UTF8CharacterStrictLength(P: PChar): integer; +begin + if p=nil then exit(0); + if ord(p^)<%10000000 then begin + // regular single byte character + exit(1); + end + else if ord(p^)<%11000000 then begin + // invalid single byte character + exit(0); + end + else if ((ord(p^) and %11100000) = %11000000) then begin + // should be 2 byte character + if (ord(p[1]) and %11000000) = %10000000 then + exit(2) + else + exit(0); + end + else if ((ord(p^) and %11110000) = %11100000) then begin + // should be 3 byte character + if ((ord(p[1]) and %11000000) = %10000000) + and ((ord(p[2]) and %11000000) = %10000000) then + exit(3) + else + exit(0); + end + else if ((ord(p^) and %11111000) = %11110000) then begin + // should be 4 byte character + if ((ord(p[1]) and %11000000) = %10000000) + and ((ord(p[2]) and %11000000) = %10000000) + and ((ord(p[3]) and %11000000) = %10000000) then + exit(4) + else + exit(0); + end else + exit(0); +end; + +function GetDefaultTextEncoding: string; +begin + if EncodingValid then begin + Result:=DefaultTextEncoding; + exit; + end; + + {$IFDEF Windows} + Result:=GetWindowsEncoding; + {$ELSE} + {$IFDEF Darwin} + Result:=EncodingUTF8; + {$ELSE} + Lang := GetEnvironmentVariable('LC_ALL'); + if Lang='' then begin + Lang := GetEnvironmentVariable('LC_MESSAGES'); + if Lang='' then + Lang := GetEnvironmentVariable('LANG'); + end; + Result:=GetUnixEncoding; + {$ENDIF} + {$ENDIF} + Result:=NormalizeEncoding(Result); + + DefaultTextEncoding:=Result; + EncodingValid:=true; +end; + +function NormalizeEncoding(const Encoding: string): string; +var + i: Integer; +begin + Result:=LowerCase(Encoding); + for i:=length(Result) downto 1 do + if Result[i]='-' then Delete(Result,i,1); +end; + +function IsASCII(const s: string): boolean; inline; +var + p: PChar; +begin + if s='' then exit(true); + p:=PChar(s); + repeat + case p^ of + #0: if p-PChar(s)=length(s) then exit(true); + #128..#255: exit(false); + end; + inc(p); + until false; +end; + +function UTF8ToUTF16(const s: string): UnicodeString; +begin + Result:=UTF8Decode(s); +end; + +function UTF16ToUTF8(const s: UnicodeString): string; +begin + if s='' then exit(''); + Result:=UTF8Encode(s); + // prevent UTF8 codepage appear in the strings - we don't need codepage + // conversion magic + SetCodePage(RawByteString(Result), CP_ACP, False); +end; + +{$IFDEF Unix} + {$I pas2jsfileutilsunix.inc} +{$ENDIF} +{$IFDEF Windows} + {$I pas2jsfileutilswin.inc} +{$ENDIF} + +procedure InternalInit; +begin + SetMultiByteConversionCodePage(CP_UTF8); + // SetMultiByteFileSystemCodePage(CP_UTF8); not needed, this is the default under Windows + SetMultiByteRTLFileSystemCodePage(CP_UTF8); + + GetDefaultTextEncoding; + {$IFDEF Windows} + NonUTF8System:=true; + {$ELSE} + NonUTF8System:=SysUtils.CompareText(DefaultTextEncoding,'UTF8')<>0; + {$ENDIF} + InitPlatform; +end; + +initialization + InternalInit; +finalization + FinalizePlatform; +end. + diff --git a/utils/pas2js/pas2jsfileutilsunix.inc b/utils/pas2js/pas2jsfileutilsunix.inc new file mode 100644 index 0000000000..d0cc2bbaf9 --- /dev/null +++ b/utils/pas2js/pas2jsfileutilsunix.inc @@ -0,0 +1,206 @@ +{%MainUnit pas2jsfileutils.pas} + +function FilenameIsAbsolute(const aFilename: string): boolean; +begin + Result:=FilenameIsUnixAbsolute(aFilename); +end; + +function ExpandFileNameUTF8(const FileName: string; BaseDir: string): string; +var + IsAbs: Boolean; + CurDir, HomeDir, Fn: String; +begin + Fn := FileName; + ForcePathDelims(Fn); + IsAbs := FileNameIsUnixAbsolute(Fn); + if (not IsAbs) then + begin + CurDir := GetCurrentDirUtf8; + if ((Length(Fn) > 1) and (Fn[1] = '~') and (Fn[2] = '/')) or (Fn = '~') then + begin + HomeDir := GetEnvironmentVariableUTF8('HOME'); + if not FileNameIsUnixAbsolute(HomeDir) then + HomeDir := ExpandFileNameUtf8(HomeDir,''); + Fn := HomeDir + Copy(Fn,2,length(Fn)); + IsAbs := True; + end; + end; + if IsAbs then + begin + Result := ResolveDots(Fn); + end + else + begin + if (BaseDir = '') then + Fn := IncludeTrailingPathDelimiter(CurDir) + Fn + else + Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn; + Fn := ResolveDots(Fn); + //if BaseDir is not absolute then this needs to be expanded as well + if not FileNameIsUnixAbsolute(Fn) then + Fn := ExpandFileNameUtf8(Fn, ''); + Result := Fn; + end; +end; + +function GetCurrentDirUTF8: String; +begin + Result:=GetCurrentDir; +end; + +function GetPhysicalFilename(const Filename: string; ExceptionOnError: boolean + ): string; +var + OldPath: String; + NewPath: String; + p: PChar; +begin + Result:=Filename; + p:=PChar(Result); + repeat + while p^='/' do + inc(p); + if p^=#0 then exit; + if p^<>'/' then + begin + repeat + inc(p); + until p^ in [#0,'/']; + OldPath:=LeftStr(Result,p-PChar(Result)); + NewPath:=ResolveSymLinks(OldPath,ExceptionOnError); + if NewPath='' then exit(''); + if OldPath<>NewPath then + begin + Result:=NewPath+copy(Result,length(OldPath)+1,length(Result)); + p:=PChar(Result)+length(NewPath); + end; + end; + until false; +end; + +function ResolveSymLinks(const Filename: string; ExceptionOnError: boolean + ): string; +var + LinkFilename: string; + AText: string; + Depth: Integer; +begin + Result:=Filename; + Depth:=0; + while Depth<12 do begin + inc(Depth); + LinkFilename:=fpReadLink(Result); + if LinkFilename='' then begin + AText:='"'+Filename+'"'; + case fpGetErrno() of + ESysEAcces: + AText:='read access denied for '+AText; + ESysENoEnt: + AText:='a directory component in '+AText + +' does not exist or is a dangling symlink'; + ESysENotDir: + AText:='a directory component in '+AText+' is not a directory'; + ESysENoMem: + AText:='insufficient memory'; + ESysELoop: + AText:=AText+' has a circular symbolic link'; + else + // not a symbolic link, just a regular file + exit; + end; + if (not ExceptionOnError) then begin + Result:=''; + exit; + end; + raise EFOpenError.Create(AText); + end else begin + if not FilenameIsAbsolute(LinkFilename) then + Result:=ExtractFilePath(Result)+LinkFilename + else + Result:=LinkFilename; + end; + end; + // probably an endless loop + if ExceptionOnError then + raise EFOpenError.Create('too many links, maybe an endless loop.') + else + Result:=''; +end; + +function GetEnvironmentVariableCountUTF8: Integer; +begin + Result:=GetEnvironmentVariableCount; +end; + +function GetEnvironmentStringUTF8(Index: Integer): string; +begin + Result:=ConsoleToUTF8(GetEnvironmentString(Index)); +end; + +function GetEnvironmentVariableUTF8(const EnvVar: string): String; +begin + Result:=ConsoleToUTF8(GetEnvironmentVariable(EnvVar)); +end; + +{$IFNDEF Darwin} +function GetUnixEncoding: string; +var + i: integer; +begin + Result:=EncodingSystem; + i:=pos('.',Lang); + if (i>0) and (i<=length(Lang)) then + Result:=copy(Lang,i+1,length(Lang)-i); +end; +{$ENDIF} + +function GetConsoleTextEncoding: string; +begin + Result:=GetDefaultTextEncoding; +end; + +function UTF8ToSystemCP(const s: string): string; +begin + if NonUTF8System and not IsASCII(s) then + begin + Result:=UTF8ToAnsi(s); + // prevent UTF8 codepage appear in the strings - we don't need codepage + // conversion magic + SetCodePage(RawByteString(Result), StringCodePage(s), False); + end + else + Result:=s; +end; + +function SystemCPToUTF8(const s: string): string; +begin + if NonUTF8System and not IsASCII(s) then + begin + Result:=AnsiToUTF8(s); + // prevent UTF8 codepage appear in the strings - we don't need codepage + // conversion magic + SetCodePage(RawByteString(Result), StringCodePage(s), False); + end + else + Result:=s; +end; + +function ConsoleToUTF8(const s: string): string; +begin + Result:=SystemCPToUTF8(s); +end; + +function UTF8ToConsole(const s: string): string; +begin + Result:=UTF8ToSystemCP(s); +end; + +procedure InitPlatform; +begin + +end; + +procedure FinalizePlatform; +begin + +end; diff --git a/utils/pas2js/pas2jsfileutilswin.inc b/utils/pas2js/pas2jsfileutilswin.inc new file mode 100644 index 0000000000..c3dc256d55 --- /dev/null +++ b/utils/pas2js/pas2jsfileutilswin.inc @@ -0,0 +1,606 @@ +{%MainUnit pas2jsfileutils.pas} + +{$IF DEFINED(UTF8_RTL) AND NOT DEFINED(WINCE)} + {$DEFINE ArgsWAsUTF8} +{$ENDIF} + +{$IFDEF OldStuff} +//Function prototypes +var _ParamStrUtf8: Function(Param: Integer): string; +{$ENDIF} + +var + ArgsW: Array of WideString; + ArgsWCount: Integer; // length(ArgsW)+1 + {$IFDEF ArgsWAsUTF8} + ArgsUTF8: Array of String; // the ArgsW array as UTF8 + OldArgV: PPChar = nil; + {$IFEND} + +{$ifndef wince} +{$IFDEF OldStuff} +function ParamStrUtf8Ansi(Param: Integer): String; +begin + Result:=ObjPas.ParamStr(Param); +end; +{$ENDIF} +{$endif wince} + +{$IFDEF OldStuff} +function ParamStrUtf8Wide(Param: Integer): String; +begin + if ArgsWCount <> ParamCount then + begin + //DebugLn('Error: ParamCount <> ArgsWCount!'); + Result := ObjPas.ParamStr(Param); + end + else + begin + if (Param <= ArgsWCount) then + {$IFDEF ACP_RTL} + Result := String(UnicodeString(ArgsW[Param])) + {$ELSE} + Result := UTF16ToUTF8(ArgsW[Param]) + {$ENDIF ACP_RTL} + else + Result := ''; + end; +end; +{$ENDIF oldstuff} + +{$IFDEF ArgsWAsUTF8} +procedure SetupArgvAsUtf8; +var + i: Integer; +begin + SetLength(ArgsUTF8,length(ArgsW)); + OldArgV:=argv; + GetMem(argv,SizeOf(Pointer)*length(ArgsW)); + for i:=0 to length(ArgsW)-1 do + begin + ArgsUTF8[i]:=ArgsW{%H-}[i]; + argv[i]:=PChar(ArgsUTF8[i]); + end; +end; +{$endif} + +procedure SetupCommandlineParametersWide; +var + ArgLen, Start, CmdLen, i, j: SizeInt; + Quote : Boolean; + Buf: array[0..259] of WChar; // need MAX_PATH bytes, not 256! + PCmdLineW: PWideChar; + CmdLineW: WideString; + + procedure AllocArg(Idx, Len:longint); + begin + if (Idx >= ArgsWCount) then + SetLength(ArgsW, Idx + 1); + SetLength(ArgsW[Idx], Len); + end; + +begin + { create commandline, it starts with the executed filename which is argv[0] } + { Win32 passes the command NOT via the args, but via getmodulefilename} + ArgsWCount := 0; + ArgLen := GetModuleFileNameW(0, @buf[0], sizeof(buf)); + + //writeln('ArgLen = ',Arglen); + + buf[ArgLen] := #0; // be safe, no terminating 0 on XP + allocarg(0,arglen); + move(buf[0],ArgsW[0][1],arglen * SizeOf(WChar)); + + //writeln('ArgsW[0] = ',ArgsW[0]); + + PCmdLineW := nil; + { Setup cmdline variable } + PCmdLineW := GetCommandLineW; + CmdLen := StrLen(PCmdLineW); + + //writeln('StrLen(PCmdLineW) = ',CmdLen); + + SetLength(CmdLineW, CmdLen); + Move(PCmdLineW^, CmdLineW[1], CmdLen * SizeOf(WChar)); + + + //debugln(CmdLineW); + //for i := 1 to CmdLen do DbgOut(DbgS(i mod 10)); debugln; + + i := 1; + while (i <= CmdLen) do + begin + //debugln('Next'); + //DbgOut('i=',DbgS(i),' CmdLineW[',DbgS(i),']=');if i<=CmdLen then debugln(CmdLineW[i]) else debugln('#0'); + //skip leading spaces + while (i <= CmdLen) and (CmdLineW[i] <= #32) do Inc(i); + //DbgOut('After skipping spaces: i=',DbgS(i),' CmdLineW[',DbgS(i),']=');if i<=CmdLen then debugln(CmdLineW[i]) else debugln('#0'); + if (i > CmdLen) then Break; + Quote := False; + Start := i; + ArgLen := 0; + while (i <= CmdLen) do + begin //find next commandline parameter + case CmdLineW[i] of + #1..#32: + begin + if Quote then + begin + //debugln('i=',DbgS(i),': Space in Quote'); + Inc(ArgLen) + end + else + begin + //debugln('i=',DbgS(i),': Space in NOT Quote'); + Break; + end; + end; + '"': + begin + if (i < CmdLen) and (CmdLineW[i+1] <> '"') then + begin + //debugln('i=',DbgS(i),': Quote := not Quote'); + Quote := not Quote + end + else + begin + //debugln('i=',DbgS(i),': Skip Quote'); + Inc(i); + end; + end; + else Inc(ArgLen); + end;//case + Inc(i); + end; //find next commandline parameter + + //debugln('ArgWCount=',DbgS(ArgsWCount),' Start=',DbgS(start),' ArgLen=',DbgS(arglen),' i=',DbgS(i)); + + //we already have (a better) ArgW[0] + if (ArgsWCount > 0) then + begin //Process commandline parameter + AllocArg(ArgsWCount, ArgLen); + Quote := False; + i := Start; + j := 1; + while (i <= CmdLen) do + begin + case CmdLineW[i] of + #1..#32: + begin + if Quote then + begin + //if j > ArgLen then debugln('Error whitespace: j > ArgLen: j=',DbgS(j),' ArgLen=',DbgS(arglen)); + ArgsW[ArgsWCount][j] := CmdLineW[i]; + Inc(j); + end + else + Break; + end; + '"': + begin + if (i < CmdLen) and (CmdLineW[i+1] <> '"') then + Quote := not Quote + else + Inc(i); + end; + else + begin + //if j > ArgLen then debugln('Error Quote: j > ArgLen: j=',DbgS(j),' ArgLen=',DbgS(arglen)); + ArgsW[ArgsWCount][j] := CmdLineW[i]; + Inc(j); + end; + end; + Inc(i); + end; + + //debugln('ArgsW[',DbgS(ArgsWCount),'] = ',ArgsW[ArgsWCount]); + end; // Process commandline parameter + Inc(ArgsWCount); + + end; + Dec(ArgsWCount); + //Note: + //On WinCe Argsv is a static function, so we cannot change it. + //This might change in the future if Argsv on WinCE will be declared as a function variable + {$IFDEF ArgsWAsUTF8} + if DefaultSystemCodePage=CP_UTF8 then + SetupArgvAsUtf8; + {$IFEND} +end; + +function FilenameIsAbsolute(const aFilename: string): boolean; +begin + Result:=FilenameIsWinAbsolute(aFilename); +end; + +procedure GetDirUtf8(DriveNr: Byte; var Dir: String); +{This procedure may not be threadsafe, because SetCurrentDirectory isn't} +{$ifndef WinCE} +var + w, D: WideString; + SavedDir: WideString; + res : Integer; +{$endif} +begin + {$ifdef WinCE} + Dir := '\'; + // Previously we sent an exception here, which is correct, but this causes + // trouble with code which isnt tested for WinCE, so lets just send a dummy result instead + // Exception.Create('[GetCurrentDirWide] The concept of the current directory doesn''t exist in Windows CE'); + {$else} + //writeln('GetDirWide START'); + if not (DriveNr = 0) then + begin + res := GetCurrentDirectoryW(0, nil); + SetLength(SavedDir, res); + res:=Windows.GetCurrentDirectoryW(res, @SavedDir[1]); + SetLength(SavedDir,res); + + D := WideChar(64 + DriveNr) + ':'; + if not SetCurrentDirectoryW(@D[1]) then + begin + Dir := Char(64 + DriveNr) + ':\'; + SetCurrentDirectoryW(@SavedDir[1]); + Exit; + end; + end; + res := GetCurrentDirectoryW(0, nil); + SetLength(w, res); + res := GetCurrentDirectoryW(res, @w[1]); + SetLength(w, res); + Dir:=UTF16ToUTF8(w); + if not (DriveNr = 0) then SetCurrentDirectoryW(@SavedDir[1]); + //writeln('GetDirWide END'); + {$endif} +end; + +function ExpandFileNameUtf8(const FileName: string; {const} BaseDir: String = ''): String; +var + IsAbs, StartsWithRoot, CanUseBaseDir : Boolean; + {$ifndef WinCE} + HasDrive: Boolean; + FnDrive, CurDrive, BaseDirDrive: Char; + {$endif} + CurDir, Fn: String; +begin + //writeln('LazFileUtils.ExpandFileNameUtf8'); + //writeln('FileName = "',FileName,'"'); + //writeln('BaseDir = "',BaseDir,'"'); + + Fn := FileName; + //if Filename uses ExtendedLengthPath scheme then it cannot be expanded + //AND it should not be altered by ForcePathDelims or ResolveDots + //See: http://msdn.microsoft.com/en-us/library/windows/desktop/aa365247%28v=vs.85%29.aspx + if (Length(Fn) > 3) and (Fn[1] = PathDelim) and (Fn[2] = PathDelim) and + (Fn[3] = '?') and (Fn[4] = PathDelim) //Do NOT use AllowDirectorySeparators here! + then Exit; + ForcePathDelims(Fn); + IsAbs := FileNameIsWinAbsolute(Fn); + if not IsAbs then + begin + StartsWithRoot := (Fn = '\') or + ((Length(Fn) > 1) and + (Fn[1] = DirectorySeparator) and + (Fn[2] <> DirectorySeparator)); + {$ifndef WinCE} + HasDrive := (Length(Fn) > 1) and + (Fn[2] = ':') and + (UpCase(Fn[1]) in ['A'..'Z']); + + if HasDrive then + begin + FnDrive := UpCase(Fn[1]); + GetDirUtf8(Byte(FnDrive)-64, CurDir{%H-}); + CurDrive := UpCase(GetCurrentDirUtf8[1]); + end + else + begin + CurDir := GetCurrentDirUtf8; + FnDrive := UpCase(CurDir[1]); + CurDrive := FnDrive; + end; + + //writeln('HasDrive = ',HasDrive,' Fn = ',Fn); + //writeln('CurDir = ',CurDir); + //writeln('CurDrive = ',CurDrive); + //writeln('FnDrive = ',FnDrive); + + if (Length(BaseDir) > 1) and (UpCase(BaseDir[1]) in ['A'..'Z']) and (BaseDir[2] = ':') then + begin + BaseDirDrive := BaseDir[1] + end + else + begin + if HasDrive then + BaseDirDrive := CurDrive + else + BaseDirDrive := #0; + end; + + //You cannot use BaseDir if both FileName and BaseDir includes a drive and they are not the same + CanUseBaseDir := ((BaseDirDrive = #0) or + (not HasDrive) or + (HasDrive and (FnDrive = BaseDirDrive))) + and (BaseDir <> ''); + + //writeln('CanUseBaseDir = ',CanUseBaseDir); + + if not HasDrive and StartsWithRoot and not CanUseBaseDir then + begin + //writeln('HasDrive and StartsWithRoot'); + Fn := Copy(CurDir,1,2) + Fn; + HasDrive := True; + IsAbs := True; + end; + //FileNames like C:foo, strip Driveletter + colon + if HasDrive and not IsAbs then Delete(Fn,1,2); + + //writeln('HasDrive = ',Hasdrive,' Fn = ',Fn); + {$else} + CanUseBaseDir := True; + {$endif WinCE} + end; + if IsAbs then + begin + //writeln('IsAbs = True -> Exit'); + Result := ResolveDots(Fn); + end + else + begin + if not CanUseBaseDir or (BaseDir = '') then + Fn := IncludeTrailingPathDelimiter(CurDir) + Fn + else + begin + if (Length(Fn) > 0) and (Fn[1] = DirectorySeparator) then Delete(Fn,1,1); + Fn := IncludeTrailingPathDelimiter(BaseDir) + Fn; + end; + + Fn := ResolveDots(Fn); + //if BaseDir is something like 'z:foo\' or '\' then this needs to be expanded as well + if not FileNameIsAbsolute(Fn) then + Fn := ExpandFileNameUtf8(Fn, ''); + Result := Fn; + end; +end; + +function GetCurrentDirUtf8: String; +{$ifndef WinCE} +var + w : UnicodeString; + res : Integer; + {$endif} +begin + {$ifdef WinCE} + Result := '\'; + // Previously we sent an exception here, which is correct, but this causes + // trouble with code which isnt tested for WinCE, so lets just send a dummy result instead + // Exception.Create('[GetCurrentDirWide] The concept of the current directory doesn''t exist in Windows CE'); + {$else} + res:=GetCurrentDirectoryW(0, nil); + SetLength(w, res); + res:=Windows.GetCurrentDirectoryW(res, @w[1]); + SetLength(w, res); + Result:=UTF16ToUTF8(w); + {$endif} +end; + +function GetPhysicalFilename(const Filename: string; ExceptionOnError: boolean + ): string; +begin + Result:=Filename; + if ExceptionOnError then ; +end; + +function ResolveSymLinks(const Filename: string; ExceptionOnError: boolean + ): string; +begin + Result:=Filename; +end; + +function GetEnvironmentVariableCountUTF8: Integer; +var + hp,p : PWideChar; +begin + Result:=0; + p:=GetEnvironmentStringsW; + if p=nil then exit; + hp:=p; + while hp^<>#0 do + begin + Inc(Result); + hp:=hp+strlen(hp)+1; + end; + FreeEnvironmentStringsW(p); +end; + +function GetEnvironmentStringUTF8(Index: Integer): string; +var + hp,p : PWideChar; +begin + Result:=''; + p:=GetEnvironmentStringsW; + if p=nil then exit; + hp:=p; + while (hp^<>#0) and (Index>1) do + begin + Dec(Index); + hp:=hp+strlen(hp)+1; + end; + if (hp^<>#0) then + Result:=UTF16ToUTF8(hp); + FreeEnvironmentStringsW(p); +end; + +function GetEnvironmentVariableUTF8(const EnvVar: string): String; +begin + Result:=UTF16ToUTF8(SysUtils.GetEnvironmentVariable(UTF8ToUTF16(EnvVar))); +end; + +// AConsole - If false, it is the general system encoding, +// if true, it is the console encoding +function GetWindowsEncoding(AConsole: Boolean = False): string; +var + cp : UINT; +{$IFDEF WinCE} +// CP_UTF8 is missing in the windows unit of the Windows CE RTL +const + CP_UTF8 = 65001; +{$ENDIF} +begin + if AConsole then cp := GetOEMCP + else cp := GetACP; + + case cp of + CP_UTF8: Result := EncodingUTF8; + else + Result:='cp'+IntToStr(cp); + end; +end; + +function GetConsoleTextEncoding: string; +begin + Result:=GetWindowsEncoding(True); +end; + +{$ifdef WinCe} +function UTF8ToSystemCP(const s: string): string; inline; +begin + Result := s; +end; +{$else} +function UTF8ToSystemCP(const s: string): string; +// result has codepage CP_ACP +var + src: UnicodeString; + len: LongInt; +begin + Result:=s; + if IsASCII(Result) then begin + // prevent codepage conversion magic + SetCodePage(RawByteString(Result), CP_ACP, False); + exit; + end; + src:=UTF8Decode(s); + if src='' then + exit; + len:=WideCharToMultiByte(CP_ACP,0,PUnicodeChar(src),length(src),nil,0,nil,nil); + SetLength(Result,len); + if len>0 then begin + WideCharToMultiByte(CP_ACP,0,PUnicodeChar(src),length(src),@Result[1],length(Result),nil,nil); + // prevent codepage conversion magic + SetCodePage(RawByteString(Result), CP_ACP, False); + end; +end; +{$endif not wince} + +{$ifdef WinCE} +function SystemCPToUTF8(const s: string): string; inline; +begin + Result := SysToUtf8(s); +end; +{$else} +// for all Windows supporting 8bit codepages (e.g. not WinCE) +function SystemCPToUTF8(const s: string): string; +// result has codepage CP_ACP +var + UTF16WordCnt: SizeInt; + UTF16Str: UnicodeString; +begin + Result:=s; + if IsASCII(Result) then begin + // prevent codepage conversion magic + SetCodePage(RawByteString(Result), CP_ACP, False); + exit; + end; + UTF16WordCnt:=MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, Pointer(s), length(s), nil, 0); + // this will null-terminate + if UTF16WordCnt>0 then + begin + setlength(UTF16Str, UTF16WordCnt); + MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, Pointer(s), length(s), @UTF16Str[1], UTF16WordCnt); + Result:=UTF16ToUTF8(UTF16Str); + end; +end; +{$endif not wince} + +{$ifdef WinCe} +function UTF8ToConsole(const s: string): string; // converts UTF8 to console string (used by Write, WriteLn) +begin + Result := UTF8ToSystemCP(s); +end; +{$else} +function UTF8ToConsole(const s: string): string; // converts UTF8 to console string (used by Write, WriteLn) +var + Dst: PChar; +begin + {$ifndef NO_CP_RTL} + Result := UTF8ToSystemCP(s); + {$else NO_CP_RTL} + Result := s; // Kept for compatibility + {$endif NO_CP_RTL} + Dst := AllocMem((Length(Result) + 1) * SizeOf(Char)); + if CharToOEM(PChar(Result), Dst) then + Result := StrPas(Dst); + FreeMem(Dst); + {$ifndef NO_CP_RTL} + SetCodePage(RawByteString(Result), CP_OEMCP, False); + {$endif NO_CP_RTL} +end; +{$endif not WinCE} + +{$ifdef WinCE} +function ConsoleToUTF8(const s: string): string;// converts console encoding to UTF8 +begin + Result := SysToUTF8(s); +end; +{$else} +function ConsoleToUTF8(const s: string): string;// converts console encoding to UTF8 +var + Dst: PChar; +begin + Dst := AllocMem((Length(s) + 1) * SizeOf(Char)); + if OemToChar(PChar(s), Dst) then + Result := StrPas(Dst) + else + Result := s; + FreeMem(Dst); + Result := SystemCPToUTF8(Result); +end; +{$endif not wince} + +procedure InitPlatform; +begin + {$ifndef WinCE} + if Win32MajorVersion <= 4 then + begin + {$IFDEF OldStuff} + _ParamStrUtf8 := @ParamStrUtf8Ansi; + {$ENDIF} + end + else + {$endif} + begin + ArgsWCount := -1; + {$IFDEF OldStuff} + _ParamStrUtf8 := @ParamStrUtf8Wide; + {$ENDIF} + SetupCommandlineParametersWide; + end; +end; + +procedure FinalizePlatform; +{$IFDEF ArgsWAsUTF8} +var + p: PPChar; +{$ENDIF} +begin + {$IFDEF ArgsWAsUTF8} + // restore argv and free memory + if OldArgV<>nil then + begin + p:=argv; + argv:=OldArgV; + Freemem(p); + end; + {$ENDIF} +end; diff --git a/utils/pas2js/pas2jslogger.pp b/utils/pas2js/pas2jslogger.pp new file mode 100644 index 0000000000..ad2a6b7a38 --- /dev/null +++ b/utils/pas2js/pas2jslogger.pp @@ -0,0 +1,723 @@ +{ Author: Mattias Gaertner 2017 mattias@freepascal.org + + Abstract: + Logging to stdout or file. + Filtering messages by number and type. + Registering messages with number, pattern and type (error, warning, note, etc). +} +unit Pas2jsLogger; + +{$mode objfpc}{$H+} +{$inline on} + +interface + +uses + Classes, SysUtils, PasTree, PScanner, jstree, jsbase, jswriter, + Pas2jsFileUtils; + +const + ExitCodeErrorInternal = 1; // internal error + ExitCodeErrorInParams = 2; // error in command line parameters + ExitCodeErrorInConfig = 3; // error in config file + ExitCodeFileNotFound = 4; + ExitCodeWriteError = 5; + ExitCodeSyntaxError = 6; + ExitCodeConverterError = 7; + +const + DefaultLogMsgTypes = [mtFatal..mtDebug]; // by default show everything + +type + + { TPas2jsMessage } + + TPas2jsMessage = class + public + Number: integer; + Typ: TMessageType; + Pattern: string; + end; + + TPas2jsLogEvent = Procedure (Sender : TObject; Const Msg : String) Of Object; + + { TPas2jsLogger } + + TPas2jsLogger = class + private + FEncoding: string; + FMsgNumberDisabled: PInteger;// sorted ascending + FMsgNumberDisabledCount: integer; + FMsg: TFPList; // list of TPas2jsMessage + FOnFormatPath: TPScannerFormatPathEvent; + FOnLog: TPas2jsLogEvent; + FOutputFile: TFileWriter; + FOutputFilename: string; + FShowMsgNumbers: boolean; + FShowMsgTypes: TMessageTypes; + FSorted: boolean; + function GetMsgCount: integer; + function GetMsgNumberDisabled(MsgNumber: integer): boolean; + function GetMsgs(Index: integer): TPas2jsMessage; inline; + function FindMsgNumberDisabled(MsgNumber: integer; FindInsertPos: boolean): integer; + procedure SetEncoding(const AValue: string); + procedure SetMsgNumberDisabled(MsgNumber: integer; AValue: boolean); + procedure SetOutputFilename(AValue: string); + procedure SetSorted(AValue: boolean); + public + constructor Create; + destructor Destroy; override; + procedure RegisterMsg(MsgType: TMessageType; MsgNumber: integer; Pattern: string); + function FindMsg(MsgNumber: integer; ExceptionOnNotFound: boolean): TPas2jsMessage; + procedure Sort; + procedure LogRaw(const Msg: string); overload; + procedure LogRaw(Args: array of const); overload; + procedure LogLn; + procedure LogMsg(MsgNumber: integer; Args: array of const; + const Filename: string = ''; Line: integer = 0; Col: integer = 0; + UseFilter: boolean = true); + procedure LogMsgIgnoreFilter(MsgNumber: integer; Args: array of const); + function MsgTypeToStr(MsgType: TMessageType): string; + procedure Log(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0; + const Filename: string = ''; Line: integer = 0; Col: integer = 0; + UseFilter: boolean = true); + function GetMsgText(MsgNumber: integer; Args: array of const): string; + function FormatMsg(MsgType: TMessageType; Msg: string; MsgNumber: integer = 0; + const Filename: string = ''; Line: integer = 0; Col: integer = 0): string; + procedure OpenOutputFile; + procedure Flush; + procedure CloseOutputFile; + procedure Reset; + public + property Encoding: string read FEncoding write SetEncoding; // normalized + property MsgCount: integer read GetMsgCount; + property Msgs[Index: integer]: TPas2jsMessage read GetMsgs; + property MsgNumberDisabled[MsgNumber: integer]: boolean read GetMsgNumberDisabled write SetMsgNumberDisabled; + property OnFormatPath: TPScannerFormatPathEvent read FOnFormatPath write FOnFormatPath; + property OutputFilename: string read FOutputFilename write SetOutputFilename; + property ShowMsgNumbers: boolean read FShowMsgNumbers write FShowMsgNumbers; + property ShowMsgTypes: TMessageTypes read FShowMsgTypes write FShowMsgTypes; + property Sorted: boolean read FSorted write SetSorted; + Property OnLog : TPas2jsLogEvent Read FOnLog Write FonLog; + end; + +function CompareP2JMessage(Item1, Item2: Pointer): Integer; + +function AsString(Element: TPasElement; Full: boolean = true): string; overload; +function AsString(Element: TJSElement): string; overload; +function DbgString(Element: TJSElement; Indent: integer): string; overload; +function DbgAsString(Element: TJSValue; Indent: integer): string; overload; +function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string; overload; +function DbgAsString(Element: TJSObjectLiteralElements; Indent: integer): string; overload; +function DbgAsString(Element: TJSObjectLiteralElement; Indent: integer): string; overload; +function DbgHexMem(p: Pointer; Count: integer): string; +function DbgStr(const s: string): string; + +implementation + +function CompareP2JMessage(Item1, Item2: Pointer): Integer; +var + Msg1: TPas2jsMessage absolute Item1; + Msg2: TPas2jsMessage absolute Item2; +begin + Result:=Msg1.Number-Msg2.Number; +end; + +function AsString(Element: TPasElement; Full: boolean): string; +begin + if Element=nil then + Result:='(no element)' + else begin + Result:=Element.GetDeclaration(Full); + end; +end; + +function AsString(Element: TJSElement): string; +var + aTextWriter: TBufferWriter; + aWriter: TJSWriter; +begin + aTextWriter:=TBufferWriter.Create(120); + aWriter:=TJSWriter.Create(aTextWriter); + aWriter.WriteJS(Element); + Result:=aTextWriter.AsAnsistring; + aWriter.Free; + aTextWriter.Free; +end; + +function DbgString(Element: TJSElement; Indent: integer): string; +begin + if Element=nil then + Result:='(*no element*)' + else if Element is TJSLiteral then begin + Result:=DbgAsString(TJSLiteral(Element).Value,Indent+2); + end else if Element is TJSPrimaryExpressionIdent then begin + Result:=String(TJSPrimaryExpressionIdent(Element).Name); + + // array literal + end else if Element is TJSArrayLiteral then begin + Result:='['+DbgAsString(TJSArrayLiteral(Element).Elements,Indent+2)+']'; + + // object literal + end else if Element is TJSObjectLiteral then begin + Result:='['+DbgAsString(TJSObjectLiteral(Element).Elements,Indent+2)+']'; + + // arguments + end else if Element is TJSArguments then begin + Result:='('+DbgAsString(TJSArguments(Element).Elements,Indent+2)+')'; + + // member + end else if Element is TJSMemberExpression then begin + Result:='('+DbgString(TJSMemberExpression(Element).MExpr,Indent+2)+')'; + // ToDo: TJSNewMemberExpression + // ToDo: TJSDotMemberExpression + // ToDo: TJSBracketMemberExpression + + // call + end else if Element is TJSCallExpression then begin + Result:=DbgString(TJSCallExpression(Element).Expr,Indent+2) + +DbgString(TJSCallExpression(Element).Args,Indent+2); + + // unary + end else if Element is TJSUnary then begin + Result:=TJSUnary(Element).PrefixOperator + +DbgString(TJSUnary(Element).A,Indent+2) + +TJSUnary(Element).PostFixOperator; + + // binary + end else if Element is TJSBinary then begin + if Element is TJSStatementList then begin + Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding + +Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent); + end else if Element is TJSVariableDeclarationList then begin + Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2)+';'+LineEnding + +Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent); + end else if Element is TJSWithStatement then begin + Result:='with ('+DbgString(TJSBinaryExpression(Element).A,Indent+2)+'){'+LineEnding + +Space(Indent)+DbgString(TJSBinaryExpression(Element).B,Indent+2)+LineEnding + +Space(Indent)+'}'; + end else if Element is TJSBinaryExpression then begin + Result:=DbgString(TJSBinaryExpression(Element).A,Indent+2); + if TJSBinaryExpression(Element).AllowCompact then + Result+=TJSBinaryExpression(Element).OperatorString + else + Result+=' '+TJSBinaryExpression(Element).OperatorString+' '; + Result+=DbgString(TJSBinaryExpression(Element).B,Indent+2); + end else begin + Result:='{: unknown binary Element: '+Element.Classname+':}'; + end; + + // ? : + end else if Element is TJSConditionalExpression then begin + Result:=DbgString(TJSConditionalExpression(Element).A,Indent+2) + +'?'+DbgString(TJSConditionalExpression(Element).B,Indent+2) + +':'+DbgString(TJSConditionalExpression(Element).C,Indent+2); + + // assignment + end else if Element is TJSAssignStatement then begin + Result:=DbgString(TJSAssignStatement(Element).LHS,Indent+2) + +TJSAssignStatement(Element).OperatorString + +DbgString(TJSAssignStatement(Element).Expr,Indent+2); + + // var + end else if Element is TJSVarDeclaration then begin + Result:=TJSVarDeclaration(Element).Name; + if TJSVarDeclaration(Element).Init<>nil then + Result+='='+DbgString(TJSVarDeclaration(Element).Init,Indent+2); + + // if(){} else {} + end else if Element is TJSIfStatement then begin + Result:='if('+DbgString(TJSIfStatement(Element).Cond,Indent+2)+'){'+LineEnding + +Space(Indent+2)+DbgString(TJSIfStatement(Element).BTrue,Indent+2)+LineEnding + +Space(Indent); + if TJSIfStatement(Element).BFalse<>nil then + Result+=' else {'+LineEnding + +Space(Indent+2)+DbgString(TJSIfStatement(Element).BFalse,Indent+2)+LineEnding + +Space(Indent)+'}'; + + // body + end else if Element is TJSBodyStatement then begin + + // while(){} + if Element is TJSWhileStatement then begin + Result:='while('+DbgString(TJSWhileStatement(Element).Cond,Indent+2)+')'; + if TJSWhileStatement(Element).Body<>nil then + Result+=DbgString(TJSWhileStatement(Element).Body,Indent) + else + Result+='{}'; + + // do{}while() + end else if Element is TJSDoWhileStatement then begin + Result:='do'; + if TJSDoWhileStatement(Element).Body<>nil then + Result+=DbgString(TJSDoWhileStatement(Element).Body,Indent) + else + Result+='{}'; + Result+='('+DbgString(TJSDoWhileStatement(Element).Cond,Indent+2)+')'; + + // for(Init;Incr;Cond)Body + end else if Element is TJSForStatement then begin + Result:='for('; + if TJSForStatement(Element).Init<>nil then + Result+=DbgString(TJSForStatement(Element).Init,Indent+2); + Result+=';'; + if TJSForStatement(Element).Cond<>nil then + Result+=DbgString(TJSForStatement(Element).Cond,Indent+2); + Result+=';'; + if TJSForStatement(Element).Incr<>nil then + Result+=DbgString(TJSForStatement(Element).Incr,Indent+2); + Result+=')'; + if TJSForStatement(Element).Body<>nil then + Result+=DbgString(TJSForStatement(Element).Body,Indent) + else + Result+='{}'; + + // {} + end else begin + if TJSBodyStatement(Element).Body<>nil then + Result+='{'+LineEnding + +Space(Indent+2)+DbgString(TJSBodyStatement(Element).Body,Indent+2)+LineEnding + +Space(Indent)+'}' + else + Result+='{}'; + end; + + end else begin + Result:='{: unknown Element: '+Element.Classname+':}'; + end; +end; + +function DbgAsString(Element: TJSValue; Indent: integer): string; +begin + if Element=nil then + Result:='(no value)' + else begin + case Element.ValueType of + jstUNDEFINED: Result:='undefined'; + jstNull: Result:='null'; + jstBoolean: Result:=BoolToStr(Element.AsBoolean,'true','false'); + jstNumber: str(Element.AsNumber,Result); + jstString: Result:=AnsiQuotedStr(Element.AsString{%H-},''''); + jstObject: Result:='{:OBJECT:}'; + jstReference: Result:='{:REFERENCE:}'; + JSTCompletion: Result:='{:COMPLETION:}'; + else Result:='{:Unknown ValueType '+IntToStr(ord(Element.ValueType))+':}'; + end; + end; + Result:=Space(Indent)+Result; +end; + +function DbgAsString(Element: TJSArrayLiteralElements; Indent: integer): string; +var + i: Integer; +begin + Result:=''; + for i:=0 to TJSArrayLiteralElements(Element).Count-1 do begin + if i>0 then Result+=','; + Result+=DbgString(TJSArrayLiteralElements(Element).Elements[i].Expr,Indent+2); + end; +end; + +function DbgAsString(Element: TJSObjectLiteralElements; Indent: integer): string; +var + i: Integer; +begin + Result:=''; + for i:=0 to TJSObjectLiteralElements(Element).Count-1 do begin + if i>0 then Result+=','; + Result+=DbgString(TJSObjectLiteralElements(Element).Elements[i].Expr,Indent+2); + end; +end; + +function DbgAsString(Element: TJSObjectLiteralElement; Indent: integer): string; +begin + Result:=String(TJSObjectLiteralElement(Element).Name) + +':'+DbgString(TJSObjectLiteralElement(Element).Expr,Indent+2); +end; + +function DbgHexMem(p: Pointer; Count: integer): string; +var + i: Integer; +begin + Result:=''; + for i:=0 to Count-1 do + Result:=Result+HexStr(ord(PChar(p)[i]),2); +end; + +function DbgStr(const s: string): string; +var + i: Integer; + c: Char; +begin + Result:=''; + for i:=1 to length(s) do begin + c:=s[i]; + case c of + #0..#31,#127..#255: Result+='$'+HexStr(ord(c),2); + else Result+=c; + end; + end; +end; + +{ TPas2jsLogger } + +function TPas2jsLogger.GetMsgs(Index: integer): TPas2jsMessage; +begin + Result:=TPas2jsMessage(FMsg[Index]); +end; + +function TPas2jsLogger.FindMsgNumberDisabled(MsgNumber: integer; + FindInsertPos: boolean): integer; +var + l, r, m, CurMsgNumber: Integer; +begin + l:=0; + r:=FMsgNumberDisabledCount-1; + m:=0; + while l<=r do begin + m:=(l+r) div 2; + CurMsgNumber:=FMsgNumberDisabled[m]; + if MsgNumber<CurMsgNumber then + r:=m-1 + else if MsgNumber>CurMsgNumber then + l:=m+1 + else + exit(m); + end; + if FindInsertPos then begin + Result:=m; + if l>m then inc(Result); + end else begin + Result:=-1; + end; +end; + +procedure TPas2jsLogger.SetEncoding(const AValue: string); +var + NewValue: String; +begin + NewValue:=NormalizeEncoding(AValue); + if FEncoding=NewValue then Exit; + //LogRaw(ClassName+': Encoding changed from "'+FEncoding+'" to "'+NewValue+'"'); + FEncoding:=NewValue; +end; + +function TPas2jsLogger.GetMsgNumberDisabled(MsgNumber: integer): boolean; +begin + Result:=FindMsgNumberDisabled(MsgNumber,false)>=0; +end; + +procedure TPas2jsLogger.SetMsgNumberDisabled(MsgNumber: integer; AValue: boolean + ); +var + InsertPos, OldCount: Integer; +begin + OldCount:=FMsgNumberDisabledCount; + if AValue then begin + // enable + InsertPos:=FindMsgNumberDisabled(MsgNumber,true); + if (InsertPos<OldCount) and (FMsgNumberDisabled[InsertPos]=MsgNumber) then + exit; // already disabled + inc(FMsgNumberDisabledCount); + ReAllocMem(FMsgNumberDisabled,SizeOf(Integer)*FMsgNumberDisabledCount); + if InsertPos<OldCount then + Move(FMsgNumberDisabled[InsertPos],FMsgNumberDisabled[InsertPos+1], + SizeOf(Integer)*(OldCount-InsertPos)); + FMsgNumberDisabled[InsertPos]:=MsgNumber; + end else begin + // disable + InsertPos:=FindMsgNumberDisabled(MsgNumber,false); + if InsertPos<0 then exit; + if InsertPos+1<OldCount then + Move(FMsgNumberDisabled[InsertPos+1],FMsgNumberDisabled[InsertPos], + SizeOf(Integer)*(OldCount-InsertPos-1)); + dec(FMsgNumberDisabledCount); + ReAllocMem(FMsgNumberDisabled,SizeOf(Integer)*FMsgNumberDisabledCount); + end; +end; + +procedure TPas2jsLogger.SetOutputFilename(AValue: string); +begin + if FOutputFilename=AValue then Exit; + CloseOutputFile; + FOutputFilename:=AValue; + if OutputFilename<>'' then + OpenOutputFile; +end; + +procedure TPas2jsLogger.SetSorted(AValue: boolean); +begin + if FSorted=AValue then Exit; + FSorted:=AValue; + if FSorted then Sort; +end; + +constructor TPas2jsLogger.Create; +begin + FMsg:=TFPList.Create; + FShowMsgTypes:=DefaultLogMsgTypes; +end; + +destructor TPas2jsLogger.Destroy; +var + i: Integer; +begin + CloseOutputFile; + for i:=0 to FMsg.Count-1 do + TObject(FMsg[i]).Free; + FreeAndNil(FMsg); + ReAllocMem(FMsgNumberDisabled,0); + FMsgNumberDisabledCount:=0; + inherited Destroy; +end; + +procedure TPas2jsLogger.RegisterMsg(MsgType: TMessageType; MsgNumber: integer; + Pattern: string); +var + Msg: TPas2jsMessage; +begin + if MsgNumber=0 then + raise Exception.Create('internal error: TPas2jsLogger.RegisterMsg MsgNumber=0'); + Msg:=TPas2jsMessage.Create; + Msg.Number:=MsgNumber; + Msg.Typ:=MsgType; + Msg.Pattern:=Pattern; + FMsg.Add(Msg); + FSorted:=false; +end; + +function TPas2jsLogger.GetMsgCount: integer; +begin + Result:=FMsg.Count; +end; + +function TPas2jsLogger.FindMsg(MsgNumber: integer; ExceptionOnNotFound: boolean + ): TPas2jsMessage; +var + l, r, m: Integer; + Msg: TPas2jsMessage; +begin + if not FSorted then Sort; + l:=0; + r:=GetMsgCount-1; + while l<=r do begin + m:=(l+r) div 2; + Msg:=Msgs[m]; + if MsgNumber<Msg.Number then + r:=m-1 + else if MsgNumber>Msg.Number then + l:=m+1 + else + exit(Msg); + end; + Result:=nil; + if ExceptionOnNotFound then + raise Exception.Create('invalid message number '+IntToStr(MsgNumber)); +end; + +procedure TPas2jsLogger.Sort; +var + i: Integer; + LastMsg, CurMsg: TPas2jsMessage; +begin + if FMsg.Count>1 then begin; + FMsg.Sort(@CompareP2JMessage); + + // check for duplicates + LastMsg:=TPas2jsMessage(FMsg[0]); + for i:=1 to FMsg.Count-1 do begin + CurMsg:=TPas2jsMessage(FMsg[i]); + if LastMsg.Number=CurMsg.Number then + raise Exception.Create('duplicate message number '+IntToStr(CurMsg.Number)+'. 1st="'+LastMsg.Pattern+'" 2nd="'+CurMsg.Pattern+'"'); + LastMsg:=CurMsg; + end; + end; + FSorted:=true; +end; + +function TPas2jsLogger.GetMsgText(MsgNumber: integer; + Args: array of const): string; +var + Msg: TPas2jsMessage; +begin + Msg:=FindMsg(MsgNumber,true); + Result:=MsgTypeToStr(Msg.Typ)+': '+Format(Msg.Pattern,Args); +end; + +procedure TPas2jsLogger.LogRaw(const Msg: string); +var + S: String; +begin + S:=Msg; + if Encoding='utf8' then + else if Encoding='console' then + S:=UTF8ToConsole(S) + else if Encoding='system' then + S:=UTF8ToSystemCP(S) + else begin + // default: write UTF-8 to outputfile and console codepage to console + if FOutputFile=nil then + S:=UTF8ToConsole(S); + end; + //writeln('TPas2jsLogger.LogRaw "',Encoding,'" "',DbgStr(S),'"'); + if FOnLog<>Nil then + FOnLog(Self,S) + else if FOutputFile<>nil then + FOutputFile.Write(S+LineEnding) + else begin + // prevent codepage conversion magic + SetCodePage(RawByteString(S), CP_OEMCP, False); + writeln(S); + end; +end; + +procedure TPas2jsLogger.LogRaw(Args: array of const); +var + s: String; + i: Integer; +begin + s:=''; + for i:=Low(Args) to High(Args) do + begin + case Args[i].VType of + vtInteger: s += IntToStr(Args[i].VInteger); + vtBoolean: s += BoolToStr(Args[i].VBoolean); + vtChar: s += Args[i].VChar; + {$ifndef FPUNONE} + vtExtended: ; // Args[i].VExtended^; + {$ENDIF} + vtString: s += Args[i].VString^; + vtPointer: ; // Args[i].VPointer; + vtPChar: s += Args[i].VPChar; + vtObject: ; // Args[i].VObject; + vtClass: ; // Args[i].VClass; + vtWideChar: s += AnsiString(Args[i].VWideChar); + vtPWideChar: s += AnsiString(Args[i].VPWideChar); + vtAnsiString: s += AnsiString(Args[i].VAnsiString); + vtCurrency: ; // Args[i].VCurrency^); + vtVariant: ; // Args[i].VVariant^); + vtInterface: ; // Args[i].VInterface^); + vtWidestring: s += AnsiString(WideString(Args[i].VWideString)); + vtInt64: s += IntToStr(Args[i].VInt64^); + vtQWord: s += IntToStr(Args[i].VQWord^); + vtUnicodeString:s += AnsiString(UnicodeString(Args[i].VUnicodeString)); + end; + end; + LogRaw(s); +end; + +procedure TPas2jsLogger.LogLn; +begin + LogRaw(''); +end; + +procedure TPas2jsLogger.LogMsg(MsgNumber: integer; Args: array of const; + const Filename: string; Line: integer; Col: integer; UseFilter: boolean); +var + s: String; + Msg: TPas2jsMessage; +begin + Msg:=FindMsg(MsgNumber,true); + if UseFilter and not (Msg.Typ in FShowMsgTypes) then exit; + if MsgNumberDisabled[MsgNumber] then exit; + s:=FormatMsg(Msg.Typ,SafeFormat(Msg.Pattern,Args),MsgNumber,Filename,Line,Col); + LogRaw(s); +end; + +procedure TPas2jsLogger.LogMsgIgnoreFilter(MsgNumber: integer; + Args: array of const); +begin + LogMsg(MsgNumber,Args,'',0,0,false); +end; + +function TPas2jsLogger.MsgTypeToStr(MsgType: TMessageType): string; +begin + case MsgType of + mtFatal: Result:='Fatal'; + mtError: Result:='Error'; + mtWarning: Result:='Warning'; + mtNote: Result:='Note'; + mtHint: Result:='Hint'; + mtInfo: Result:='Info'; + mtDebug: Result:='Debug'; + else Result:='Verbose'; + end; +end; + +procedure TPas2jsLogger.Log(MsgType: TMessageType; Msg: string; + MsgNumber: integer; const Filename: string; Line: integer; Col: integer; + UseFilter: boolean); +var + s: String; +begin + if UseFilter and not (MsgType in FShowMsgTypes) then exit; + if MsgNumberDisabled[MsgNumber] then exit; + s:=FormatMsg(MsgType,Msg,MsgNumber,Filename,Line,Col); + LogRaw(s); +end; + +function TPas2jsLogger.FormatMsg(MsgType: TMessageType; Msg: string; + MsgNumber: integer; const Filename: string; Line: integer; Col: integer + ): string; +// e.g. file(line,col) type: (number) msg +var + s: String; +begin + s:=''; + if Filename<>'' then begin + if Assigned(OnFormatPath) then + s+=OnFormatPath(Filename) + else + s+=Filename; + if Line>0 then begin + s+='('+IntToStr(Line); + if Col>0 then s+=','+IntToStr(Col); + s+=')'; + end; + if s<>'' then s+=' '; + end; + s+=MsgTypeToStr(MsgType)+': '; + if ShowMsgNumbers and (MsgNumber<>0) then + s+='('+IntToStr(MsgNumber)+') '; + s+=Msg; + Result:=s; +end; + +procedure TPas2jsLogger.OpenOutputFile; +begin + if FOutputFile<>nil then exit; + if OutputFilename='' then + raise Exception.Create('Log has empty OutputFilename'); + if DirectoryExists(OutputFilename) then + raise Exception.Create('Log is directory: "'+OutputFilename+'"'); + FOutputFile:=TFileWriter.Create(OutputFilename); + if (Encoding='') or (Encoding='utf8') then + FOutputFile.Write(UTF8BOM); +end; + +procedure TPas2jsLogger.Flush; +begin + if FOutputFile<>nil then + FOutputFile.Flush; +end; + +procedure TPas2jsLogger.CloseOutputFile; +begin + if FOutputFile=nil then exit; + FOutputFile.Flush; + FreeAndNil(FOutputFile); +end; + +procedure TPas2jsLogger.Reset; +begin + OutputFilename:=''; + if FMsgNumberDisabled<>nil then begin + ReAllocMem(FMsgNumberDisabled,0); + FMsgNumberDisabledCount:=0; + end; + ShowMsgNumbers:=false; + FShowMsgTypes:=DefaultLogMsgTypes; +end; + +end. + diff --git a/utils/pas2js/pas2jspparser.pp b/utils/pas2js/pas2jspparser.pp new file mode 100644 index 0000000000..732e8ba24e --- /dev/null +++ b/utils/pas2js/pas2jspparser.pp @@ -0,0 +1,157 @@ +{ Author: Mattias Gaertner 2017 mattias@freepascal.org + + Abstract: + Extends the FCL Pascal parser for the language subset of pas2js. +} +unit Pas2jsPParser; + +{$mode objfpc}{$H+} +{$inline on} + +interface + +uses + Classes, SysUtils, PParser, PScanner, PasTree, PasResolver, fppas2js, + Pas2jsLogger; + +const // Messages + nFinalizationNotSupported = 3001; + sFinalizationNotSupported = 'Finalization section is not supported.'; + +type + + { TPas2jsPasParser } + + TPas2jsPasParser = class(TPasParser) + private + FLog: TPas2jsLogger; + public + constructor Create(AScanner: TPascalScanner; + AFileResolver: TBaseFileResolver; AEngine: TPasTreeContainer); + procedure SetLastMsg(MsgType: TMessageType; MsgNumber: integer; + Const Fmt : String; Args : Array of const); + procedure RaiseParserError(MsgNumber: integer; Args: array of const); + procedure ParseSubModule(var Module: TPasModule); + property Log: TPas2jsLogger read FLog write FLog; + end; + + TOnFindModule = function(const aUnitname: String): TPasModule of object; + TOnCheckSrcName = procedure(const aElement: TPasElement) of object; + + { TPas2jsCompilerResolver } + + TPas2jsCompilerResolver = class(TPas2JSResolver) + private + FLog: TPas2jsLogger; + FOnCheckSrcName: TOnCheckSrcName; + FOnContinueParsing: TNotifyEvent; + FOnFindModule: TOnFindModule; + FP2JParser: TPas2jsPasParser; + public + function CreateElement(AClass: TPTreeElement; const AName: String; + AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; + overload; override; + function FindModule(const aUnitname: String): TPasModule; override; + procedure ContinueParsing; override; + public + Owner: TObject; + property OnContinueParsing: TNotifyEvent read FOnContinueParsing write FOnContinueParsing; + property OnFindModule: TOnFindModule read FOnFindModule write FOnFindModule; + property OnCheckSrcName: TOnCheckSrcName read FOnCheckSrcName write FOnCheckSrcName; + property Log: TPas2jsLogger read FLog write FLog; + property P2JParser: TPas2jsPasParser read FP2JParser write FP2JParser; + end; + +procedure RegisterMessages(Log: TPas2jsLogger); + +implementation + +procedure RegisterMessages(Log: TPas2jsLogger); +var + LastMsgNumber: integer; + + procedure r(MsgType: TMessageType; MsgNumber: integer; const MsgPattern: string); + var + s: String; + begin + if (LastMsgNumber>=0) and (MsgNumber<>LastMsgNumber+1) then + begin + s:='gap in registered message numbers: '+IntToStr(LastMsgNumber)+' '+IntToStr(MsgNumber); + writeln('Pas2jsPParser.RegisterMessages ',s); + raise Exception.Create(s); + end; + Log.RegisterMsg(MsgType,MsgNumber,MsgPattern); + LastMsgNumber:=MsgNumber; + end; + +begin + LastMsgNumber:=-1; + r(mtError,nFinalizationNotSupported,sFinalizationNotSupported); +end; + +{ TPas2jsPasParser } + +constructor TPas2jsPasParser.Create(AScanner: TPascalScanner; + AFileResolver: TBaseFileResolver; AEngine: TPasTreeContainer); +begin + inherited Create(AScanner,AFileResolver,AEngine); + Options:=Options+[po_asmwhole,po_resolvestandardtypes]; +end; + +procedure TPas2jsPasParser.SetLastMsg(MsgType: TMessageType; + MsgNumber: integer; const Fmt: String; Args: array of const); +begin + inherited SetLastMsg(MsgType,MsgNumber,Fmt,Args); +end; + +procedure TPas2jsPasParser.RaiseParserError(MsgNumber: integer; Args: array of const); +var + Msg: TPas2jsMessage; +begin + Msg:=Log.FindMsg(MsgNumber,true); + SetLastMsg(Msg.Typ,MsgNumber,Msg.Pattern,Args); + raise EParserError.Create(LastMsg,Scanner.CurFilename, + Scanner.CurRow,Scanner.CurColumn); +end; + +procedure TPas2jsPasParser.ParseSubModule(var Module: TPasModule); +begin + Module:=nil; + NextToken; + SaveComments; + case CurToken of + tkUnit: + ParseUnit(Module); + tkLibrary: + ParseLibrary(Module); + else + ExpectToken(tkUnit); + end; +end; + +{ TPas2jsCompilerResolver } + +function TPas2jsCompilerResolver.CreateElement(AClass: TPTreeElement; + const AName: String; AParent: TPasElement; AVisibility: TPasMemberVisibility; + const ASrcPos: TPasSourcePos): TPasElement; +begin + if AClass=TFinalizationSection then + (CurrentParser as TPas2jsPasParser).RaiseParserError(nFinalizationNotSupported,[]); + Result:=inherited; + if (Result is TPasModule) then + OnCheckSrcName(Result); +end; + +function TPas2jsCompilerResolver.FindModule(const aUnitname: String): TPasModule; +begin + Result:=OnFindModule(aUnitname); +end; + +procedure TPas2jsCompilerResolver.ContinueParsing; +begin + OnContinueParsing(Self); +end; + +end. +